OCXOCMP5 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Optimize Order Check Sub-Routines) ;2/02/99 13:39
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN() ;
;
Q:$G(OCXWARN) 1
N OCXPC,OCXD0,OCXD1,OCXD2,OCXD3
;
S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0)) Q:'OCXD0 D
.I '$G(OCXAUTO) W:($X>60) ! W "."
.S OCXD1=0 F S OCXD1=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0,OCXD1)) Q:'OCXD1 D
..S OCXLINE=$G(^TMP("OCXCMP",$J,"C CODE",OCXD0,OCXD1,0))
..Q:'$L(OCXLINE) Q:'(OCXLINE["||LINE:")
..F OCXPC=2:1:$L(OCXLINE,"||LINE:") S OCXD2=+$P(OCXLINE,"||LINE:",OCXPC) D
...S:OCXD2 ^TMP("OCXCMP",$J,"CALLREF",OCXD2,OCXD0,OCXD1)=""
;
S OCXD0=$G(^TMP("OCXCMP",$J,"LINE","B","SCAN")) I OCXD0 D
.S OCXD1=0 F S OCXD1=$O(^TMP("OCXCMP",$J,"C CODE",OCXD0,OCXD1)) Q:'OCXD1 Q:(^(OCXD1,0)["D @OCXPGM")
.S OCXD3=199999 F S OCXD3=$O(^TMP("OCXCMP",$J,"LINE",OCXD3)) Q:(OCXD3>299999) D
..S ^TMP("OCXCMP",$J,"CALLREF",OCXD3,OCXD0,OCXD1)=""
..I '$G(OCXAUTO) W:($X>60) ! W "."
;
F S OCXFLAG=0 D Q:'OCXFLAG
.S OCXD0=0 F S OCXD0=$O(^TMP("OCXCMP",$J,"CALLREF",OCXD0)) Q:'OCXD0 D
..I '$G(OCXAUTO) W:($X>60) ! W "."
..N OCXNSUB,OCXLLAB,OCXCNT,OCXCHG,OCXCOD1,OCXCOD2
..N OCXD1,OCXD2,OCXCALL,OCXOP1,OCXOP2,OCXOP3,OCXREC1,OCXREC2
..S OCXCALL=" D ||LINE:"_OCXD0_"||"
..Q:$D(^TMP("OCXCMP",$J,"C CODE",OCXD0,13000))
..Q:$D(^TMP("OCXCMP",$J,"C CODE",OCXD0,16001))
..S OCXCOD1=$G(^TMP("OCXCMP",$J,"C CODE",OCXD0,16000,0)) Q:'$L(OCXCOD1)
..S OCXOP1=$G(^TMP("OCXCMP",$J,"C CODE",OCXD0,16000,"OPLIST"))
..S (OCXCNT,OCXCHG)=0
..S OCXD1=0 F S OCXD1=$O(^TMP("OCXCMP",$J,"CALLREF",OCXD0,OCXD1)) Q:'OCXD1 D
...S OCXD2=0 F S OCXD2=$O(^TMP("OCXCMP",$J,"CALLREF",OCXD0,OCXD1,OCXD2)) Q:'OCXD2 D
....S OCXCOD2=$G(^TMP("OCXCMP",$J,"C CODE",OCXD1,OCXD2,0)) Q:'(OCXCOD2[OCXCALL)
....S OCXOP2=$G(^TMP("OCXCMP",$J,"C CODE",OCXD1,OCXD2,"OPLIST"))
....S OCXOP3=$E(OCXOP2,1,$L(OCXOP2)-1)
....S OCXCNT=OCXCNT+1
....Q:(($L(OCXCOD1)+$L(OCXCOD2))>OCXCLL)
....Q:(OCXOP2["Y")
....I $L(OCXOP1),$L(OCXOP3),($E(OCXOP1,1)=$E(OCXOP3,$L(OCXOP3))),'($E(OCXOP1,1)="Z") D
.....S OCXCOD2=$P(OCXCOD2,OCXCALL,1)_","_$P(OCXCOD1," ",3,999)_$P(OCXCOD2,OCXCALL,2,9999)
.....S OCXOP2=OCXOP3_$E(OCXOP1,2,$L(OCXOP1))_$P(OCXOP2,"D",2,999)
....E D
.....S OCXCOD2=$P(OCXCOD2,OCXCALL,1)_OCXCOD1_$P(OCXCOD2,OCXCALL,2,9999)
.....S OCXOP2=OCXOP3_OCXOP1_$P(OCXOP2,"D",2,999)
....S ^TMP("OCXCMP",$J,"C CODE",OCXD1,OCXD2,0)=OCXCOD2
....S ^TMP("OCXCMP",$J,"C CODE",OCXD1,OCXD2,"OPLIST")=OCXOP2
....K ^TMP("OCXCMP",$J,"CALLREF",OCXD0,OCXD1,OCXD2)
....F OCXPC=2:2:$L(OCXCOD2,"D ||LINE:") S OCXD3=+$P(OCXCOD2,"D ||LINE:",OCXPC) D
.....S ^TMP("OCXCMP",$J,"CALLREF",OCXD3,OCXD1,OCXD2)=""
....S OCXCHG=OCXCHG+1,OCXFLAG=1
..I (OCXCNT=OCXCHG) D
...S OCXLLAB=$P(^TMP("OCXCMP",$J,"LINE",OCXD0),U,1)
...Q:'($E(OCXLLAB,1,3)="CHK")
...K ^TMP("OCXCMP",$J,"C CODE",OCXD0)
...K ^TMP("OCXCMP",$J,"CALLREF",OCXD0)
...K ^TMP("OCXCMP",$J,"LINE",OCXD0)
...K ^TMP("OCXCMP",$J,"LINE","B",OCXLLAB)
;
Q OCXWARN
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMP5 3099 printed Oct 16, 2024@18:25:18 Page 2
OCXOCMP5 ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Optimize Order Check Sub-Routines) ;2/02/99 13:39
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
EN() ;
+1 ;
+2 if $GET(OCXWARN)
QUIT 1
+3 NEW OCXPC,OCXD0,OCXD1,OCXD2,OCXD3
+4 ;
+5 SET OCXD0=0
FOR
SET OCXD0=$ORDER(^TMP("OCXCMP",$JOB,"C CODE",OCXD0))
if 'OCXD0
QUIT
Begin DoDot:1
+6 IF '$GET(OCXAUTO)
if ($X>60)
WRITE !
WRITE "."
+7 SET OCXD1=0
FOR
SET OCXD1=$ORDER(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,OCXD1))
if 'OCXD1
QUIT
Begin DoDot:2
+8 SET OCXLINE=$GET(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,OCXD1,0))
+9 if '$LENGTH(OCXLINE)
QUIT
if '(OCXLINE["||LINE
QUIT
+10 FOR OCXPC=2:1:$LENGTH(OCXLINE,"||LINE:")
SET OCXD2=+$PIECE(OCXLINE,"||LINE:",OCXPC)
Begin DoDot:3
+11 if OCXD2
SET ^TMP("OCXCMP",$JOB,"CALLREF",OCXD2,OCXD0,OCXD1)=""
End DoDot:3
End DoDot:2
End DoDot:1
+12 ;
+13 SET OCXD0=$GET(^TMP("OCXCMP",$JOB,"LINE","B","SCAN"))
IF OCXD0
Begin DoDot:1
+14 SET OCXD1=0
FOR
SET OCXD1=$ORDER(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,OCXD1))
if 'OCXD1
QUIT
if (^(OCXD1,0)["D @OCXPGM")
QUIT
+15 SET OCXD3=199999
FOR
SET OCXD3=$ORDER(^TMP("OCXCMP",$JOB,"LINE",OCXD3))
if (OCXD3>299999)
QUIT
Begin DoDot:2
+16 SET ^TMP("OCXCMP",$JOB,"CALLREF",OCXD3,OCXD0,OCXD1)=""
+17 IF '$GET(OCXAUTO)
if ($X>60)
WRITE !
WRITE "."
End DoDot:2
End DoDot:1
+18 ;
+19 FOR
SET OCXFLAG=0
Begin DoDot:1
+20 SET OCXD0=0
FOR
SET OCXD0=$ORDER(^TMP("OCXCMP",$JOB,"CALLREF",OCXD0))
if 'OCXD0
QUIT
Begin DoDot:2
+21 IF '$GET(OCXAUTO)
if ($X>60)
WRITE !
WRITE "."
+22 NEW OCXNSUB,OCXLLAB,OCXCNT,OCXCHG,OCXCOD1,OCXCOD2
+23 NEW OCXD1,OCXD2,OCXCALL,OCXOP1,OCXOP2,OCXOP3,OCXREC1,OCXREC2
+24 SET OCXCALL=" D ||LINE:"_OCXD0_"||"
+25 if $DATA(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,13000))
QUIT
+26 if $DATA(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,16001))
QUIT
+27 SET OCXCOD1=$GET(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,16000,0))
if '$LENGTH(OCXCOD1)
QUIT
+28 SET OCXOP1=$GET(^TMP("OCXCMP",$JOB,"C CODE",OCXD0,16000,"OPLIST"))
+29 SET (OCXCNT,OCXCHG)=0
+30 SET OCXD1=0
FOR
SET OCXD1=$ORDER(^TMP("OCXCMP",$JOB,"CALLREF",OCXD0,OCXD1))
if 'OCXD1
QUIT
Begin DoDot:3
+31 SET OCXD2=0
FOR
SET OCXD2=$ORDER(^TMP("OCXCMP",$JOB,"CALLREF",OCXD0,OCXD1,OCXD2))
if 'OCXD2
QUIT
Begin DoDot:4
+32 SET OCXCOD2=$GET(^TMP("OCXCMP",$JOB,"C CODE",OCXD1,OCXD2,0))
if '(OCXCOD2[OCXCALL)
QUIT
+33 SET OCXOP2=$GET(^TMP("OCXCMP",$JOB,"C CODE",OCXD1,OCXD2,"OPLIST"))
+34 SET OCXOP3=$EXTRACT(OCXOP2,1,$LENGTH(OCXOP2)-1)
+35 SET OCXCNT=OCXCNT+1
+36 if (($LENGTH(OCXCOD1)+$LENGTH(OCXCOD2))>OCXCLL)
QUIT
+37 if (OCXOP2["Y")
QUIT
+38 IF $LENGTH(OCXOP1)
IF $LENGTH(OCXOP3)
IF ($EXTRACT(OCXOP1,1)=$EXTRACT(OCXOP3,$LENGTH(OCXOP3)))
IF '($EXTRACT(OCXOP1,1)="Z")
Begin DoDot:5
+39 SET OCXCOD2=$PIECE(OCXCOD2,OCXCALL,1)_","_$PIECE(OCXCOD1," ",3,999)_$PIECE(OCXCOD2,OCXCALL,2,9999)
+40 SET OCXOP2=OCXOP3_$EXTRACT(OCXOP1,2,$LENGTH(OCXOP1))_$PIECE(OCXOP2,"D",2,999)
End DoDot:5
+41 IF '$TEST
Begin DoDot:5
+42 SET OCXCOD2=$PIECE(OCXCOD2,OCXCALL,1)_OCXCOD1_$PIECE(OCXCOD2,OCXCALL,2,9999)
+43 SET OCXOP2=OCXOP3_OCXOP1_$PIECE(OCXOP2,"D",2,999)
End DoDot:5
+44 SET ^TMP("OCXCMP",$JOB,"C CODE",OCXD1,OCXD2,0)=OCXCOD2
+45 SET ^TMP("OCXCMP",$JOB,"C CODE",OCXD1,OCXD2,"OPLIST")=OCXOP2
+46 KILL ^TMP("OCXCMP",$JOB,"CALLREF",OCXD0,OCXD1,OCXD2)
+47 FOR OCXPC=2:2:$LENGTH(OCXCOD2,"D ||LINE:")
SET OCXD3=+$PIECE(OCXCOD2,"D ||LINE:",OCXPC)
Begin DoDot:5
+48 SET ^TMP("OCXCMP",$JOB,"CALLREF",OCXD3,OCXD1,OCXD2)=""
End DoDot:5
+49 SET OCXCHG=OCXCHG+1
SET OCXFLAG=1
End DoDot:4
End DoDot:3
+50 IF (OCXCNT=OCXCHG)
Begin DoDot:3
+51 SET OCXLLAB=$PIECE(^TMP("OCXCMP",$JOB,"LINE",OCXD0),U,1)
+52 if '($EXTRACT(OCXLLAB,1,3)="CHK")
QUIT
+53 KILL ^TMP("OCXCMP",$JOB,"C CODE",OCXD0)
+54 KILL ^TMP("OCXCMP",$JOB,"CALLREF",OCXD0)
+55 KILL ^TMP("OCXCMP",$JOB,"LINE",OCXD0)
+56 KILL ^TMP("OCXCMP",$JOB,"LINE","B",OCXLLAB)
End DoDot:3
End DoDot:2
End DoDot:1
if 'OCXFLAG
QUIT
+57 ;
+58 QUIT OCXWARN
+59 ;
