- 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 Dec 13, 2024@02:24:42 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 ;