?INSPECT,SYMBOLS 
INT       RTV              := 0;                                             ! return value
INT     LNP              := 0;                                               ! length to point to
INT     ERP              := 0;                                               ! error to point to
INT     CNT              := 0;                                               ! loop count
INT     TPC              := 0;                                               ! passed call count
INT     TFC              := 0;                                               ! failed call count
INT     PAS              := 1;                                               ! passed test count
INT     ERR              := 1;                                               ! failed test count
INT     BTB              := 1;                                               ! byte to byte count
INT     BTW              := 1;                                               ! byte to word count
INT     BTE              := 1;                                               ! byte to element count
INT     WTB              := 1;                                               ! word to byte count
INT     WTW              := 1;                                               ! word to word count
INT     WTE              := 1;                                               ! word to element count
INT     ETB              := 1;                                               ! element to byte count
INT     ETW              := 1;                                               ! elemant to word count
INT     ETE              := 1;                                               ! elemant to element count
INT     T^NUM            := -1;                                              ! terminal number
INT     PPD[0:8];
INT       T^NAME[0:11] := 12 * ["  "];                                       ! terminal name
INT       T^B[0:38] := 39 * ["  "];                                          ! terminal output buffer
STRING    ARRAY^BYTE[0:26] := 27 * ["B"];                                    ! byte array direct odd(27)
STRING    EQ^BYTE[0:26] = ARRAY^BYTE;                                        ! equivalenced byte odd(27)
INT       EQ^NOTB[0:12] = ARRAY^BYTE;                                        ! equivalenced word even(26)
INT       ARRAY^WORD[0:12] := 13 * ["Ww"];                                   ! word array direct even(26)
INT       EQ^WORD[0:12] = ARRAY^WORD;                                        ! equivalenced word even(26)
STRING    EQ^NOTW[0:24] = ARRAY^WORD;                                        ! equivalenced word odd(25)
STRING   .I^B[0:26] := 27 * [" "];                                           ! byte array indirect
INT      .I^W[0:12] := 13 * ["  "];                                          ! word array indirect
LITERAL   SP                = 3;                                             ! PLUS OFFSET START
LITERAL   SM                = -3;                                            ! MINUS OFFSET START
STRING   .P^B[3:13] := 10 * [" "];                                          ! plus byte array indirect
INT      .P^W[3:08] := 05 * ["  "];                                         ! plus word array indirect
STRING   .M^B[-3:07] := 10 * [" "];                                          ! minus byte array indirect
INT      .M^W[-3:02] := 05 * ["  "];                                         ! minus word array indirect
STRING   .SN               := @T^NAME '<<' 1;                                ! string -> terminal name
STRING   .BP               := @ARRAY^BYTE;                                   ! byte pointer
INT      .C^NAME[0:11] := ["TESTINIT", 8 * ["  "]];
INT      .WP               := @ARRAY^WORD;                                   ! word pointer
INT      .LPT              := @LNP;
INT      .EPT              := @ERP;
STRING   .PTR^S;
INT      .PD;
INT      .PI;
INT      .IID;
INT       ID               := 0;
INT       DOUBLE           := 0;
FIXED     F                := 0F;
 FIXED(1) F1               := 0F; 
 FIXED(2) F2               := 0F; 
 FIXED(-1) FM1              := 0F; 
 FIXED(-2) FM2              := 0F; 
 FIXED(*) FA               := 0F; 
INT(32) GARRAY^INIT[0:99] := [10 *[0D],
 10 *[10D], 10 *[100D], 10 *[1000D], 10 *[10000D], 10 *[10000D], 10 *[1000D], 10 *[100D], 10 *[10D], 10 *[0D] ];
STRING P^ST = 'P' := [065,
 066,
 067,
 068, 069, 070, 071, 072, 073, 074, 075, 076, 077, 078, 079, 080, 081, 082, 083, 084, 085, 086, 087, 088, 089, 090];
 ?PAGE 
STRUCT  .SF;                                                                ! struct template  fixed
   BEGIN
   FIXED(*)  FA;   ! fixed 0
   FIXED(1)  F1  = FA;   ! fixed 1 -> fa
   FIXED(-1) FM1 = F1;   ! fixed-1 -> f1
   END;
STRUCT  SB^DEF(*);                                                          ! struct template  byte
   BEGIN
   STRUCT DUMMY;
      BEGIN
      STRING    A^B[0:26];   ! 27 bytes
      STRING    EQ^BYTE[0:26] = A^B;   ! equivalenced byte
      END;
   END;
STRUCT   STRUCT^BYTE(SB^DEF);                                               !   direct struct  byte
STRUCT  .ISB(SB^DEF);                                                       ! indirect struct  byte
STRUCT  SW^DEF(*);                                                          ! struct template  word
   BEGIN
   INT      A^W[0:12];   ! 26 bytes
   END;
STRUCT   STRUCT^WORD(SW^DEF);                                               !   direct struct  word
INT     .ISW(SW^DEF);                                                        ! indirect struct  word
STRUCT  .ISE(SW^DEF);                                                       ! indirect struct  element
STRUCT  OS^DEF(*);                                                          ! offset struct template
   BEGIN
   INT      W^P[ 3:8];   ! 10 bytes
   INT      W^M[-3:2];   ! 10 bytes
   END;
STRUCT  .PSE(OS^DEF)[3:8];                                                  ! + offset struct  element
STRUCT  .NSE(OS^DEF)[-3:2];   ! - offset struct  element
STRUCT .STARTUP^MSG;
   BEGIN
   INT    MSG^CODE;
   INT    DEFAULTS   [0:7];
   INT    IN^FILE    [0:11];
   INT    OUT^FILE   [0:11];
   STRING PARAMETERS [0:199];
   END;
STRUCT ASSIGN^MSG^DEF (*);
   BEGIN
   INT MSG^CODE;   ! -2 !
   STRUCT LOGICALUNIT;
      BEGIN
      STRING PROGNAMELEN;
      STRING PROGNAME [0:30];
      STRING FILENAMELEN;
      STRING FILENAME [0:30];
      END;
   INT(32) FIELDMASK;
   STRUCT INTERNAL^NAME;
      BEGIN
      INT FULL [0:11];
      END;
   STRUCT TANDEM^NAME = INTERNAL^NAME;
      BEGIN
      INT VOL    [0:3];
      INT SUBVOL [0:3];
      INT DFILE  [0:3];
      END;
   INT PRIMARYEXTENT;
   INT SECONDARYEXTENT;
   INT FILECODE;
   INT EXCLUSIONSPEC;
   INT ACCESSSPEC;
   INT RECORDSIZE;
   INT BLOCKSIZE;
   END;
STRUCT PARAM^MSG^DEF(*);
   BEGIN
   INT MSG^CODE;   ! -3 !
   INT NUMPARAMS;
   STRING PARAMETERS[0:1023];
   END;
LITERAL  ALL^BITS     = %B1111111111111111;
 ?PAGE 
 PROC CLEAR^CNT; 
 FORWARD; 
 INT PROC TEST^NOTSUB(PD,PI) VARIABLE; 
 FORWARD; 
 INT PROC TEST^SUB(PS,PD,PI); 
 FORWARD; 
 INT PROC TEST^MOVE^INDIRECT; 
 FORWARD; 
 INT PROC TEST^SCAN; 
 FORWARD; 
 ?PAGE 
 PROC CLEAR^CNT; 
 BEGIN 
 ERR := 0; 
 BTB := 0; 
 BTW := 0; 
 BTE := 0; 
 WTB := 0; 
 WTW := 0; 
 WTE := 0; 
 ETB := 0; 
 ETW := 0; 
 ETE := 0; 
 PAS := 0; 
 CALL WRITE(T^NUM,T^B,0); 
 END; 
 INT PROC TEST^NOTSUB(PD,PI) VARIABLE; 
INT     PD;
INT     PI;
 BEGIN 
 IF $PARAM(PD) THEN 
     PD := PD + 1; 
 RETURN PD; 
 END; 
 INT PROC TEST^SUB(PS,PD,PI); 
STRUCT .PS;
   BEGIN
   INT      PSI;
   STRING   PSS;
   END;
INT     PD;
INT    .PI;
 BEGIN 
LITERAL UNIQUE              = -1;
STRUCT Q^DEF(*);
   BEGIN
   STRUCT DUMMY;
      BEGIN
      STRUCT US;
         BEGIN
         INT    UNIQUE;
         END;
      STRUCT NUS = US;
         BEGIN
         INT    NOT^UNIQUE;
         END;
      END;
   END;
STRUCT QST(Q^DEF);
STRUCT  S^DEF(*);
   BEGIN
   STRING B^A[0:25];
   INT    I^27;
   END;
STRUCT .LST(S^DEF);
INT    .IIT := @LST;
INT    .IID;
INT     ID;
 INT SUBPROC DO^SUB2(PD,PI) VARIABLE; 
INT     PD;
INT    .PI;
 BEGIN 
INT      .IID;
INT       ID;
 ID   := ID + 1; 
 @IID := @ID; 
 IF $PARAM(PD) AND PD > 1 THEN 
     BEGIN 
     QST.DUMMY.US.UNIQUE := UNIQUE; 
     IF QST.DUMMY.US.UNIQUE = UNIQUE AND 
        QST.DUMMY.NUS.NOT^UNIQUE = UNIQUE THEN 
        PAS := PAS + 1 
     ELSE
  
        ERR := ERR + 1; 
     LST.B^A ':=' "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; 
     LST.I^27 :=  UNIQUE; 
     @PI := @LST; 
     END 
 ELSE
  
     BEGIN 
     PAS := PAS + 1; 
     CALL TEST^SUB(ISW,ID,IID); 
     END; 
 RETURN PD := PD + 1; 
 END; 
 INT SUBPROC DO^SUB1(PD,PI) VARIABLE; 
INT     PD;
INT    .PI;
 BEGIN 
INT      .IID;
INT       ID;
 ID   := ID + 1; 
 @IID := @ID; 
 IF PD = 0 THEN 
     RETURN TEST^NOTSUB(PD) 
 ELSE
  
     RETURN DO^SUB2(PD); 
 END; 
!------------------------test^call main--------------------------------------
 ID   := ID + 1; 
 @IID := @ID; 
 WHILE (DO^SUB1(PAS) < 3) DO 
     PAS := PAS + 1; 
 IF IIT = LST FOR $LEN(LST) THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF IIT = P^ST FOR $OCCURS(P^ST) THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 BP[3] ':=' [13]; 
 @WP    :=  @IIT[BP[3]]; 
 IF WP = UNIQUE THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF  ARRAY^BYTE  = EQ^BYTE FOR  ($LEN(ARRAY^BYTE) * $OCCURS(ARRAY^BYTE))) THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF  ARRAY^WORD  = EQ^WORD FOR  ($LEN(ARRAY^WORD) * $OCCURS(ARRAY^WORD))) THEN 
     WTW := WTW + 1 
 ELSE
  
     ERR := ERR + 1; 
! EQUIVALENCED TESTS
 IF  ARRAY^BYTE  = EQ^BYTE FOR ($LEN( ARRAY^BYTE) * $OCCURS( ARRAY^BYTE)) THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF  ARRAY^BYTE  = EQ^NOTB FOR ($LEN( ARRAY^BYTE) * $OCCURS( ARRAY^BYTE)) THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF  ARRAY^WORD  = EQ^WORD FOR ($LEN( ARRAY^WORD) * $OCCURS( ARRAY^WORD)) THEN 
     WTW := WTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF  ARRAY^WORD  = EQ^NOTW FOR ($LEN( ARRAY^WORD) * $OCCURS( ARRAY^WORD)) THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 RETURN ERR; 
 END; 
 INT PROC TEST^MOVE^INDIRECT; 
 BEGIN 
! BYTE TESTS
 @BP  := @ ARRAY^BYTE ; 
 IF BP  =  ARRAY^BYTE  FOR $OCCURS( ARRAY^BYTE) THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP := @ ARRAY^WORD  '<<' 1; 
 IF BP  =  ARRAY^WORD  FOR $LEN( ARRAY^WORD) * $OCCURS( ARRAY^WORD) THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  := @ISW '<<' 1; 
 IF BP  = ISW FOR  ($LEN(STRUCT^WORD) * $OCCURS(STRUCT^WORD))) THEN 
     BTE := BTE + 1 
 ELSE
  
     ERR := ERR + 1; 
 @I^B := @ ARRAY^BYTE ; 
 IF I^B =  ARRAY^BYTE  FOR $OCCURS( ARRAY^BYTE) THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 @I^B:= @ ARRAY^WORD  '<<' 1; 
 IF I^B =  ARRAY^WORD  FOR  ($LEN(  ARRAY^WORD) * $OCCURS(  ARRAY^WORD)) THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 @I^B := @ISB.DUMMY.A^B; 
 IF I^B = ISB.DUMMY.A^B FOR  ($LEN(STRUCT^BYTE) * $OCCURS(STRUCT^BYTE))) THEN 
     BTE := BTE + 1 
 ELSE
  
     ERR := ERR + 1; 
! WORD TESTS
 @WP  := @ ARRAY^BYTE  '>>' 1; 
 IF WP  =  ARRAY^BYTE  FOR $OCCURS( ARRAY^BYTE) THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 @WP := @ ARRAY^WORD ; 
 IF WP  =  ARRAY^WORD  FOR $LEN( ARRAY^WORD) * $OCCURS( ARRAY^WORD) THEN 
     WTW := WTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 @WP   := @ISW; 
 IF WP  = ISW FOR  ($LEN(STRUCT^WORD) * $OCCURS(STRUCT^WORD))) THEN 
     WTE := WTE + 1 
 ELSE
  
     ERR := ERR + 1; 
 @I^W := @ ARRAY^BYTE  '>>' 1; 
 IF I^W =  ARRAY^BYTE  FOR $OCCURS( ARRAY^BYTE) THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 @I^W := @ ARRAY^WORD ; 
 IF I^W =  ARRAY^WORD  FOR $LEN( ARRAY^WORD) * $OCCURS( ARRAY^WORD) THEN 
     WTW := WTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 @I^W := @ISW; 
 IF I^W = ISW FOR  ($LEN(STRUCT^WORD) * $OCCURS(STRUCT^WORD))) THEN 
     WTE := WTE + 1 
 ELSE
  
     ERR := ERR + 1; 
! ELEMENT TESTS
 @ISE := @ ARRAY^BYTE  '>>' 1; 
 IF ISE =  ARRAY^BYTE  FOR  ($LEN(ARRAY^BYTE) * $OCCURS(ARRAY^BYTE))) THEN 
     ETB := ETB + 1 
 ELSE
  
     ERR := ERR + 1; 
 @ISE := @ ARRAY^WORD ; 
 IF ISE =  ARRAY^WORD  FOR  ($LEN(ARRAY^WORD) * $OCCURS(ARRAY^WORD))) THEN 
      ETW := ETW + 1 
 ELSE
  
      ERR := ERR + 1; 
 @ISE := @ISW; 
 IF ISE  = ISW FOR  ($LEN(STRUCT^WORD) * $OCCURS(STRUCT^WORD))) THEN 
     ETE := ETE + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     INDIRECT TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 PAS:=PAS+BTB+BTW+BTE+WTB+WTW+WTE+ETB+ETW+ETE; 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 RETURN ERR; 
 END; 
 INT PROC TEST^SCAN; 
 BEGIN 
   ARRAY^BYTE   ':=' "ABCDEFGHIJKLMNOPQRSTUVWXY" & [0]; 
 SCAN  ARRAY^BYTE  UNTIL "G" -> @BP; 
 IF NOT $CARRY AND @BP '-' @ ARRAY^BYTE  = 6 THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN  ARRAY^BYTE  UNTIL "G" -> @WP; 
 IF NOT $CARRY AND @WP '-' @ ARRAY^BYTE  = 6 THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  := @ ARRAY^WORD  '<<' 1; 
 BP  ':=' "ABCDEFGHIJKLMNOPQRSTUVWXY" & [0]; 
 SCAN BP UNTIL "G" -> @I^B; 
 IF NOT $CARRY AND @I^B '-' @BP = 6 THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN BP UNTIL "G" -> @WP; 
 IF NOT $CARRY AND @WP '-' @BP = 6 THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN BP UNTIL "Z" -> @ISE; 
 IF $CARRY THEN 
     BTE := BTE + 1 
 ELSE
  
     ERR := ERR + 1; 
 BP ':=' "AAAAAAGHIJKLMNOPQRSTUVWXY" & [0]; 
 SCAN BP WHILE "A" -> @I^B; 
 IF NOT $CARRY AND @I^B '-' @BP = 6 THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN BP WHILE "A" -> @WP; 
 IF NOT $CARRY AND @WP '-' @BP = 6 THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN BP WHILE "A" -> @ISE; 
 IF NOT $CARRY AND @ISE '-' @BP = 6 THEN 
     BTE := BTE + 1 
 ELSE
  
     ERR := ERR + 1; 
! WORD TESTS
   ARRAY^WORD  ':=' "ABCDEFGHIJKLMNOPQRSTUVWXY" & 0; 
 @WP  := @ ARRAY^WORD ; 
 SCAN WP UNTIL "G" -> @BP; 
 IF NOT $CARRY AND @BP '-' @WP '<<' 1 = 6 THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN WP UNTIL "Z" -> @BP; 
 IF $CARRY THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 WP ':=' "AAAAAAGHIJKLMNOPQRSTUVWXY" & 0; 
 SCAN WP WHILE "A" -> @BP; 
 IF NOT $CARRY AND @BP '-' @WP '<<' 1 = 6 THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN  ARRAY^WORD  UNTIL "G" -> @BP; 
 IF NOT $CARRY AND @BP '-' @ ARRAY^WORD  '<<' 1 = 6 THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN  ARRAY^WORD  UNTIL "G" -> @WP; 
 IF NOT $CARRY AND @WP '-' @ ARRAY^WORD  '<<' 1 = 6 THEN 
     WTW := WTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN  ARRAY^WORD  UNTIL "G" -> @ISE; 
 IF NOT $CARRY AND @ISE '-' @ ARRAY^WORD  '<<' 1 = 6 THEN 
     WTE := WTE + 1 
 ELSE
  
     ERR := ERR + 1; 
! ELEMENT TESTS
 ISB ':=' "ABCDEFGHIJKLMNOPQRSTUVWXY" & [0]; 
 SCAN ISB UNTIL "G" -> @BP; 
 IF NOT $CARRY AND @BP '-' @ISB.DUMMY.A^B = 6 THEN 
     ETB := ETB + 1 
 ELSE
  
     ERR := ERR + 1; 
 SCAN ISB UNTIL "G" -> @WP; 
 IF NOT $CARRY AND @WP '-' @ISB.DUMMY.A^B = 6 THEN 
     ETW := ETW + 1 
 ELSE
  
     ERR := ERR + 1; 
 ISB ':=' "ABCDEFGHIJKLMNOPQRSTUVWXY" & [0]; 
 SCAN ISB UNTIL "G" -> @ISE; 
 IF NOT $CARRY AND @ISE '-' @ISB '<<' 1 = 6 THEN 
     ETE := ETE + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     SCAN     TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 PAS:=PAS+BTB+BTW+BTE+WTB+WTW+WTE+ETB+ETW+ETE; 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 RETURN ERR; 
 END; 
 INT PROC TEST^RSCAN; 
 BEGIN 
   ARRAY^BYTE  ':=' [0] & "BCDEFGHIJKLMNOPQRSTUVWXYZ"; 
 @BP  :=  @ ARRAY^BYTE [25]; 
 RSCAN BP UNTIL "S" -> @I^B; 
 IF NOT $CARRY AND @BP '-' @I^B = 7 THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 RSCAN  ARRAY^BYTE [25] UNTIL "S" -> @WP; 
 IF NOT $CARRY AND @ ARRAY^BYTE [25] '-' @WP = 7 THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 RSCAN BP UNTIL "A" -> @ISE; 
 IF $CARRY THEN 
     BTE := BTE + 1 
 ELSE
  
     ERR := ERR + 1; 
   ARRAY^BYTE  ':=' [0] & "BCDEFGHIJKLMNOPQRSYYYYYYY"; 
 RSCAN BP WHILE "Y" -> @WP; 
 IF NOT $CARRY AND @BP '-' @WP = 7 THEN 
     BTW := BTW + 1 
 ELSE
  
     ERR := ERR + 1; 
 RSCAN BP WHILE "Y" -> @I^B; 
 IF NOT $CARRY AND @BP '-' @I^B = 7 THEN 
     BTB := BTB + 1 
 ELSE
  
     ERR := ERR + 1; 
!WORD TESTS
   ARRAY^WORD  ':=' 0 & "CDEFGHIJKLMNOPQRSTUVWXYZ"; 
 RSCAN  ARRAY^WORD [12] UNTIL "S" -> @BP; 
 IF NOT $CARRY AND @ ARRAY^WORD [12] '<<' 1 '-' @BP = 6 THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 @WP  :=  @ ARRAY^WORD [12]; 
 RSCAN WP UNTIL "S" -> @BP; 
 IF NOT $CARRY AND @WP '<<' 1 '-' @BP = 6 THEN 
     WTB := WTB + 1 
 ELSE
  
     ERR := ERR + 1; 
 RSCAN WP UNTIL "B" -> @ISE; 
 IF $CARRY THEN 
     WTE := WTE + 1 
 ELSE
  
     ERR := ERR + 1; 
   ARRAY^WORD  ':=' 0 & "CDEFGHIJKLMNOPQRSYYYYYYY"; 
 RSCAN  ARRAY^WORD [12] WHILE "Y" -> @WP; 
 IF NOT $CARRY AND @ ARRAY^WORD [12] '<<' 1 '-' @WP = 6 THEN 
     WTW := WTW + 1 
 ELSE
  
     ERR := ERR + 1; 
! ELEMENT TESTS
 ISB ':=' [0] & "BCDEFGHIJKLMNOPQRSTUVWXYZ"; 
 RSCAN ISB.DUMMY.A^B[25] UNTIL "S" -> @BP; 
 IF NOT $CARRY AND @ISB.DUMMY.A^B[25] '-' @BP = 6 THEN 
     ETB := ETB + 1 
 ELSE
  
     ERR := ERR + 1; 
 RSCAN ISB.DUMMY.A^B[25] UNTIL "S" -> @WP; 
 IF NOT $CARRY AND @ISB.DUMMY.A^B[25] '-' @WP = 6 THEN 
     ETW := ETW + 1 
 ELSE
  
     ERR := ERR + 1; 
 ISB ':=' [0] & "BCDEFGHIJKLMNOPQRSTUVWXYZ"; 
 RSCAN ISB.DUMMY.A^B[25] UNTIL "S" -> @ISE; 
 IF NOT $CARRY AND @ISB.DUMMY.A^B[25] '-' @ISE = 6 THEN 
     ETE := ETE + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     RSCAN    TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 PAS:=PAS+BTB+BTW+BTE+WTB+WTW+WTE+ETB+ETW+ETE; 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 RETURN ERR; 
 END; 
 PROC TEST^AND^BIT; 
 BEGIN 
INT I;
 I := ALL^BITS.<0:7>; 
 IF NOT I.<0:7> THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 I := (%HFFFF).<8:15>; 
 IF NOT I.<0:7> THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  :=  @T^B '<<' 1; 
 BP  ':=' "~~~" & BP FOR 1 WORDS & "BIT & &  TEST" 
                 & BP FOR 5 BYTES & BP FOR 2 BYTES & BP FOR 5 BYTES & 
           "FAILED       = xxxx"  & BP FOR 2 BYTES & BP FOR 4 BYTES & 
           "PASSED       = XXXX"  & BP FOR 1 WORDS; 
!NON ZERO TESTS
 FOR I := 0 TO 4 DO 
      BEGIN 
       P^W [I+3] := I; 
       P^B [I+3] := I; 
       M^W [I-3] := I; 
       M^B [I-3] := I; 
      PSE[I+3].W^P[I+3] := I; 
      NSE[I-3].W^M[I-3] := I; 
      END; 
 IF  P^W [3] =  M^W [-3] AND  P^B [3] =  M^B [-3] THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF  P^W [7] =  M^W [01] AND  P^B [7] =  M^B [01] THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF PSE[3].W^P[3] = NSE[-3].W^M[-3] THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 IF PSE[7].W^P[7] = NSE[01].W^M[01] THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 CALL WRITE(T^NUM,T^B,0); 
 T^B ':=' "     ALL      TESTS           FAILED       = XXXX      PASSED       = XXXX   "; 
 CALL NUMOUT(BP[45],TFC,10,4); 
 CALL NUMOUT(BP[70],TPC,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 CALL WRITE(T^NUM,T^B,0); 
 CALL WRITE(T^NUM,T^B,0); 
 RETURN; 
 END; 
 INT PROC TEST^VAR(P1,P2,P3,P4,P5,P6,P7,P8,P9,FORMAT) VARIABLE; 
INT .P1;
INT     .P3;
INT  P2;
INT     P4;
INT     P5;
INT     P6;
INT     P7;
INT     P8;
INT     P9;
INT     FORMAT;
 BEGIN 
 IF $PARAM(P1) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF NOT $PARAM(P2) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF $PARAM(P3) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF NOT $PARAM(P4) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF $PARAM(P5) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF NOT $PARAM(P6) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF $PARAM(P7) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF NOT $PARAM(P8) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF NOT $PARAM(P9) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 IF NOT $PARAM(FORMAT) THEN 
     P1 := P1 + 1 
 ELSE
  
     P3 := P3 + 1; 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     PARAM    TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 RETURN(ERR); 
 END; 
 INT PROC TEST^FIXED; 
 BEGIN 
 FA := FA + 1F; 
 IF FA = 1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F := F + 1F; 
 IF F = 1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F := F + 0.1F; 
 IF F = 1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F := F + 10F; 
 IF F = 11F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F1 := F1 + 0.1F; 
 IF F1 = 0.1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F1  := F1  +  0.01F; 
 IF F1 = 0.1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F1 := F1 + 1F; 
 IF F1 = 1.1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F2 := F2 + 0.01F; 
 IF F2 = 0.01F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F2 := F2 + 0.001F; 
 IF F2 = 0.01F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F2 := F2 + 1F; 
 IF F2 = 1.01F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 F2:=0.01F; 
 F1:=0.1F; 
 F2 := F2 + F1; 
 IF F2 = 0.11F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM1 := FM1 + 10F; 
 IF FM1 = 10F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM1 := FM1 + 1F; 
 IF FM1 = 10F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM1 := FM1 + 100F; 
 IF FM1 = 110F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM2 := FM2 + 100F; 
 IF FM2 = 100F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM2 := FM2 + 10F; 
 IF FM2 = 100F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM2 := FM2 +  1000F; 
 IF FM2 = 1100F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 FM2:=100F; 
 FM1:=10F; 
 FM1 := FM1 + FM2; 
 IF FM1 = 110F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 SF.FA :=   1F; 
 SF.F1 := 0.1F; 
 SF.F1 := SF.F1 + SF.FA; 
 IF SF.F1 = 1.1F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 SF.FA  :=   1F; 
 SF.FM1 :=  10F; 
 SF.FA  := SF.FA + SF.FM1; 
 IF SF.FA = 11F THEN 
     PAS := PAS + 1 
 ELSE
  
     ERR := ERR + 1; 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     FIXED    TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 RETURN(ERR); 
 END; 
 PROC ARM^TRAP; 
 BEGIN 
 CODE  (RDE);                                                               !turn off TRAP 1
 CODE  (ANRI %577);                                                         !turn off TRAP 2
 CODE  (SETE);                                                              !turn off TRAP 3
 RETURN; 
 END; 
 PROC HANDLE^STARTUP^MSG(RUCB,PASSTHRU,STARTUP^MSG^P,MESLEN,MATCH)VARIABLE; 
INT .RUCB;
INT     .PASSTHRU;
INT     .STARTUP^MSG^P;
INT     MESLEN;
INT     MATCH;
 BEGIN 
 STARTUP^MSG ':=' STARTUP^MSG^P FOR MESLEN BYTES; 
 CALL SHIFTSTRING(STARTUP^MSG.PARAMETERS, 
                  $OCCURS(STARTUP^MSG.PARAMETERS),0); 
 SCAN STARTUP^MSG.PARAMETERS WHILE " " -> @PTR^S; 
 IF $CARRY OR NOT (FNAMEEXPAND(PTR^S,C^NAME,STARTUP^MSG.DEFAULTS)) THEN 
     TFC := TFC + 1 
 ELSE
  
     TPC := TPC + 1; 
 END; 
 PROC HANDLE^ASSIGN^MSG(RUCB, PASSTHRU, ASSIGN^MSG, MESLEN, MATCH) VARIABLE; 
INT .RUCB;
INT     .PASSTHRU;
INT     .ASSIGN^MSG (ASSIGN^MSG^DEF);
INT     MESLEN;
INT     MATCH;
    BEGIN 
STRING  .LOGICAL^NAME          [ 0:30];
    IF $HIGH(ASSIGN^MSG.FIELDMASK).<0> <> 1 THEN 
       RETURN; 
    LOGICAL^NAME ':=' 30 * [ " "]; 
    LOGICAL^NAME ':=' ASSIGN^MSG.LOGICALUNIT.FILENAME FOR 
                      ASSIGN^MSG.LOGICALUNIT.FILENAMELEN BYTES; 
    END; 
 PROC HANDLE^PARAM^MSG(RUCB, PASSTHRU, PARAM^MSG, MESLEN, MATCH) VARIABLE; 
INT .RUCB;
INT     .PASSTHRU;
INT     .PARAM^MSG (PARAM^MSG^DEF);
INT     MESLEN;
INT     MATCH;
    BEGIN 
INT      NAME^LEN;
INT      PARAM^CNT;
STRING  .PARAM^MSG^NAME;
STRING  .PARAM^MSG^VALUE;
STRING  .PARAM^NAME[0:30];
STRING  .SBP;
INT      VALUE^LEN;
    PARAM^CNT := 0; 
    @SBP := @PARAM^MSG.PARAMETERS[0]; 
    WHILE (PARAM^CNT := PARAM^CNT + 1) <= PARAM^MSG.NUMPARAMS DO 
       BEGIN 
       NAME^LEN         :=  SBP; 
       @PARAM^MSG^NAME  :=  @SBP[1]; 
       VALUE^LEN        :=  SBP[NAME^LEN + 1]; 
       @PARAM^MSG^VALUE :=  @SBP[NAME^LEN + 2]; 
       PARAM^NAME      ':=' 30 * [" "]; 
       PARAM^NAME      ':=' PARAM^MSG^NAME FOR NAME^LEN; 
       @SBP := @SBP + NAME^LEN + VALUE^LEN + 2; 
       END; 
    END; 
 PROC INIT; 
 BEGIN 
INT(32) LARRAY^INIT[0:99] := [10 *[0D],
 10 *[10D], 10 *[100D], 10 *[1000D], 10 *[10000D], 10 *[10000D], 10 *[1000D], 10 *[100D], 10 *[10D], 10 *[0D] ];
 CALL ARM^TRAP; 
 CALL INITIALIZER(,,HANDLE^STARTUP^MSG, 
                     HANDLE^PARAM^MSG, 
                     HANDLE^ASSIGN^MSG,0); 
 CALL GETCRTPID (MYPID,  PPD); 
 CALL LOOKUPPROCESSNAME (PPD); 
 IF = THEN 
     BEGIN 
     TPC := TPC + 1; 
     PPD[3] ':=' "            "; 
     END 
 ELSE
  
     BEGIN 
     TFC := TFC + 1; 
     PPD ':=' "UNNAMED           "; 
     END; 
 STACK (0);                                                                 !push 0   on stack
 STORE  ERR;                                                                !pull err off stack
 IF ERR = 0 THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 IF DOUBLE = 0 THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 IF LARRAY^INIT = GARRAY^INIT THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 ERR := 0; 
   PAS := 0; 
   BTB := 0; 
   BTW := 0; 
   BTE := 0; 
   WTB := 0; 
   WTW := 0; 
   WTE := 0; 
   ETB := 0; 
   ETW := 0; 
   ETE := 0; 
 CALL MYTERM(T^NAME); 
 CALL OPEN(T^NAME,T^NUM); 
 IF = THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 RTV:=PROCESS_GETINFO_(  ,  ,  ,  ,  , SN: ($LEN( T^NAME) * $OCCURS( T^NAME)),LPT, , , , , , , , , ,EPT); 
 IF NOT RTV THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 RTV := FILE_OPEN_(T^NAME:LNP,T^NUM); 
 IF NOT RTV THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 IF (ARRAY^BYTE = "BBBBBBBBBBBBBBBBBBBBBBBBBBB") THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 IF (ARRAY^WORD = "WwWwWwWwWwWwWwWwWwWwWwWwWw") THEN 
     TPC := TPC + 1 
 ELSE
  
     TFC := TFC + 1; 
 @BP  :=  @T^B '<<' 1; 
   BP ':=' "                        AEI   TAL TO C Conversion test " -> @BP; 
 T^B[2] ':=' PPD FOR 10 BYTES; 
 CALL WRITE(T^NUM,T^B,0); 
 CALL WRITE(T^NUM,T^B,(@BP '-' @T^B '<<' 1)); 
 CALL WRITE(T^NUM,T^B,0); 
 CALL WRITE(T^NUM,T^B,0); 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     INIT     TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],TFC,10,4); 
 CALL NUMOUT(BP[70],TPC,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 CALL WRITE(T^NUM,T^B,0); 
 END; 
 PROC WRITE^RESULT; 
 BEGIN 
 @BP  :=  @T^B '<<' 1; 
 T^B ':=' "     SUBPROC  TEST            FAILED       = XXXX      PASSED       = XXXX  "; 
 CALL NUMOUT(BP[45],ERR,10,4); 
 CALL NUMOUT(BP[70],PAS,10,4); 
 CALL WRITE(T^NUM,T^B, $LEN(T^B) * $OCCURS(T^B)); 
 END; 
 PROC CONVERT^TEST MAIN; 
 BEGIN 
 CALL INIT; 
 DO 
    BEGIN 
    CASE CNT OF 
       BEGIN 
       0         -> BEGIN 
                    IF NOT TEST^SUB(@ISW,ID,IID) THEN 
                       TPC := TPC + 1 
                    ELSE
  
                       TFC := TFC + 1; 
                    CALL WRITE^RESULT; 
                    END; 
       1         -> IF NOT TEST^MOVE^INDIRECT THEN 
                       TPC := TPC + 1 
                    ELSE
  
                       TFC := TFC + 1; 
       2         -> IF NOT TEST^SCAN THEN 
                       TPC := TPC + 1 
                    ELSE
  
                       TFC := TFC + 1; 
       3         -> IF NOT TEST^RSCAN THEN 
                       TPC := TPC + 1 
                    ELSE
  
                       TFC := TFC + 1; 
       4         -> IF NOT TEST^VAR(PAS,,ERR,,BTB,,BTW) THEN 
                       TPC := TPC + 1 
                    ELSE
  
                       TFC := TFC + 1; 
       5         -> IF NOT TEST^FIXED THEN 
                       TPC := TPC + 1 
                    ELSE
  
                       TFC := TFC + 1; 
       OTHERWISE -> CNT := 6; 
       END; 
    CALL CLEAR^CNT; 
    END 
 UNTIL (CNT := CNT + 1) > 5; 
 CALL TEST^AND^BIT; 
 RETURN; 
 END;