OCXOCMPO ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Get Compiler Function Subroutines) ;2/02/99 12:58
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN() ;
;
N OCXD0,OCXD1,OCXSR,OCXNAME
;
S (OCXWARN,OCXD0)=0 F S OCXD0=$O(^OCXS(860.8,OCXD0)) Q:'OCXD0 D Q:OCXWARN
.;
.I '$G(OCXAUTO) W:($X>60) ! W "."
.;
.K OCXSR M OCXSR=^OCXS(860.8,OCXD0,"CODE")
.K OCXSR(0)
.S OCXD1=0 F S OCXD1=$O(OCXSR(OCXD1)) Q:'OCXD1 D
..S OCXMODE=$P(OCXSR(OCXD1,0),";",1)
..S OCXSR(OCXD1,0)=$P(OCXSR(OCXD1,0),";",2,999)
..F Q:'(OCXSR(OCXD1,0)["%%%%") S OCXSR(OCXD1,0)=$P(OCXSR(OCXD1,0),"""%%%%""",1)_"||LNTAG||"_$P(OCXSR(OCXD1,0),"""%%%%""",2,999)
..I (OCXMODE["T+"),'OCXTRACE K OCXSR(OCXD1)
..I (OCXMODE["T-"),OCXTRACE K OCXSR(OCXD1)
..I (OCXMODE["L+"),'OCXTLOG K OCXSR(OCXD1)
.D REINDEX(.OCXSR,0)
.Q:'$D(OCXSR(1,0))
.I (OCXSR(1,0)[";"),'$L($P(OCXSR(1,0),";",2)) S OCXSR(1,0)=OCXSR(1,0)_" Compiler Function: "_$P($G(^OCXS(860.8,OCXD0,0)),U,1)
.S OCXNAME=$P(OCXSR(1,0),";",1)
.S:(OCXNAME["(") OCXNAME=$P(OCXNAME,"(",1)
.I '$L(OCXNAME) D WARN^OCXOCMPV("Subroutine Name Not found",8,OCXD0,"EN+20^OCXOCMPO") Q
.;
.I OCXTRACE D
..F OCXD1=1:1,0 I OCXD1 Q:'$D(OCXSR(OCXD1,0)) Q:'($E($P(OCXSR(OCXD1,0)," ",2),1)=";")
..I OCXD1 S:(OCXD1>1) OCXD1=OCXD1-1 D
...N OCXPC,OCXARG,OCXARGL
...S OCXSR(OCXD1+.0001,0)=" W:$G(OCXTRACE) !,||LNTAG||,?27,""Compiler Function "_$P(OCXSR(1,0),";",1)_" Execution trace. """
...S OCXARGL=$P(OCXSR(1,0),";",1) Q:'(OCXARGL["(")
...S OCXARGL=$P($P(OCXARGL,"(",2),")",1)
...F OCXPC=1:1:$L(OCXARGL,",") S OCXARG=$P(OCXARGL,",",OCXPC) D
....S OCXSR(OCXD1+(OCXPC/100),0)=" W:$G(OCXTRACE) !,?35,"" "_$E(" ",1,(9-$L(OCXARG)))_OCXARG_": "",$G("_OCXARG_")"
...S OCXSR(OCXD1+(OCXPC+1/100),0)=" W:$G(OCXTRACE) !"
..D REINDEX(.OCXSR,0)
.;
.M ^TMP("OCXCMP",$J,"INCLUDE",OCXNAME)=OCXSR
.;
Q:OCXWARN 1
;
; Build local term lookup function
;
D TERMLKUP^OCXOCMPU
;
S OCXNAME="" F S OCXNAME=$O(^TMP("OCXCMP",$J,"INCLUDE",OCXNAME)) Q:'$L(OCXNAME) D
.N LAST,SIZE,CALL,PC,SUBR
.K OCXSR M OCXSR=^TMP("OCXCMP",$J,"INCLUDE",OCXNAME)
.S LAST=$O(OCXSR(" "),-1)
.S:'($G(OCXSR(LAST,0))=" ;") OCXSR(LAST+1,0)=" ;"
.S OCXD1=0 F S OCXD1=$O(OCXSR(OCXD1)) Q:'OCXD1 D
..S SIZE=$G(SIZE)+$L(OCXSR(OCXD1,0))
..F PC=2:1:$L(OCXSR(OCXD1,0),"$$") D
...S SUBR=$P($P(OCXSR(OCXD1,0),"$$",PC),"(",1)
...I $D(^TMP("OCXCMP",$J,"INCLUDE",SUBR)) S OCXSR("CALLS",SUBR)=""
.S OCXSR("SIZE")=SIZE
.K ^TMP("OCXCMP",$J,"INCLUDE",OCXNAME)
.M ^TMP("OCXCMP",$J,"INCLUDE",OCXNAME)=OCXSR
;
Q 0
;
REINDEX(ARRAY,NDX2) ;
;
N TEMP,NDX1 M TEMP=ARRAY K ARRAY
S NDX1="" F S NDX1=$O(TEMP(NDX1)) Q:'$L(NDX1) D
.I $L(TEMP(NDX1,0)) S NDX2=NDX2+1 M ARRAY(NDX2)=TEMP(NDX1)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPO 2830 printed Apr 09, 2024@21:32:47 Page 2
OCXOCMPO ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Get Compiler Function Subroutines) ;2/02/99 12:58
+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 NEW OCXD0,OCXD1,OCXSR,OCXNAME
+3 ;
+4 SET (OCXWARN,OCXD0)=0
FOR
SET OCXD0=$ORDER(^OCXS(860.8,OCXD0))
if 'OCXD0
QUIT
Begin DoDot:1
+5 ;
+6 IF '$GET(OCXAUTO)
if ($X>60)
WRITE !
WRITE "."
+7 ;
+8 KILL OCXSR
MERGE OCXSR=^OCXS(860.8,OCXD0,"CODE")
+9 KILL OCXSR(0)
+10 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXSR(OCXD1))
if 'OCXD1
QUIT
Begin DoDot:2
+11 SET OCXMODE=$PIECE(OCXSR(OCXD1,0),";",1)
+12 SET OCXSR(OCXD1,0)=$PIECE(OCXSR(OCXD1,0),";",2,999)
+13 FOR
if '(OCXSR(OCXD1,0)["%%%%")
QUIT
SET OCXSR(OCXD1,0)=$PIECE(OCXSR(OCXD1,0),"""%%%%""",1)_"||LNTAG||"_$PIECE(OCXSR(OCXD1,0),"""%%%%""",2,999)
+14 IF (OCXMODE["T+")
IF 'OCXTRACE
KILL OCXSR(OCXD1)
+15 IF (OCXMODE["T-")
IF OCXTRACE
KILL OCXSR(OCXD1)
+16 IF (OCXMODE["L+")
IF 'OCXTLOG
KILL OCXSR(OCXD1)
End DoDot:2
+17 DO REINDEX(.OCXSR,0)
+18 if '$DATA(OCXSR(1,0))
QUIT
+19 IF (OCXSR(1,0)[";")
IF '$LENGTH($PIECE(OCXSR(1,0),";",2))
SET OCXSR(1,0)=OCXSR(1,0)_" Compiler Function: "_$PIECE($GET(^OCXS(860.8,OCXD0,0)),U,1)
+20 SET OCXNAME=$PIECE(OCXSR(1,0),";",1)
+21 if (OCXNAME["(")
SET OCXNAME=$PIECE(OCXNAME,"(",1)
+22 IF '$LENGTH(OCXNAME)
DO WARN^OCXOCMPV("Subroutine Name Not found",8,OCXD0,"EN+20^OCXOCMPO")
QUIT
+23 ;
+24 IF OCXTRACE
Begin DoDot:2
+25 FOR OCXD1=1:1,0
IF OCXD1
if '$DATA(OCXSR(OCXD1,0))
QUIT
if '($EXTRACT($PIECE(OCXSR(OCXD1,0)," ",2),1)=";")
QUIT
+26 IF OCXD1
if (OCXD1>1)
SET OCXD1=OCXD1-1
Begin DoDot:3
+27 NEW OCXPC,OCXARG,OCXARGL
+28 SET OCXSR(OCXD1+.0001,0)=" W:$G(OCXTRACE) !,||LNTAG||,?27,""Compiler Function "_$PIECE(OCXSR(1,0),";",1)_" Execution trace. """
+29 SET OCXARGL=$PIECE(OCXSR(1,0),";",1)
if '(OCXARGL["(")
QUIT
+30 SET OCXARGL=$PIECE($PIECE(OCXARGL,"(",2),")",1)
+31 FOR OCXPC=1:1:$LENGTH(OCXARGL,",")
SET OCXARG=$PIECE(OCXARGL,",",OCXPC)
Begin DoDot:4
+32 SET OCXSR(OCXD1+(OCXPC/100),0)=" W:$G(OCXTRACE) !,?35,"" "_$EXTRACT(" ",1,(9-$LENGTH(OCXARG)))_OCXARG_": "",$G("_OCXARG_")"
End DoDot:4
+33 SET OCXSR(OCXD1+(OCXPC+1/100),0)=" W:$G(OCXTRACE) !"
End DoDot:3
+34 DO REINDEX(.OCXSR,0)
End DoDot:2
+35 ;
+36 MERGE ^TMP("OCXCMP",$JOB,"INCLUDE",OCXNAME)=OCXSR
+37 ;
End DoDot:1
if OCXWARN
QUIT
+38 if OCXWARN
QUIT 1
+39 ;
+40 ; Build local term lookup function
+41 ;
+42 DO TERMLKUP^OCXOCMPU
+43 ;
+44 SET OCXNAME=""
FOR
SET OCXNAME=$ORDER(^TMP("OCXCMP",$JOB,"INCLUDE",OCXNAME))
if '$LENGTH(OCXNAME)
QUIT
Begin DoDot:1
+45 NEW LAST,SIZE,CALL,PC,SUBR
+46 KILL OCXSR
MERGE OCXSR=^TMP("OCXCMP",$JOB,"INCLUDE",OCXNAME)
+47 SET LAST=$ORDER(OCXSR(" "),-1)
+48 if '($GET(OCXSR(LAST,0))=" ;")
SET OCXSR(LAST+1,0)=" ;"
+49 SET OCXD1=0
FOR
SET OCXD1=$ORDER(OCXSR(OCXD1))
if 'OCXD1
QUIT
Begin DoDot:2
+50 SET SIZE=$GET(SIZE)+$LENGTH(OCXSR(OCXD1,0))
+51 FOR PC=2:1:$LENGTH(OCXSR(OCXD1,0),"$$")
Begin DoDot:3
+52 SET SUBR=$PIECE($PIECE(OCXSR(OCXD1,0),"$$",PC),"(",1)
+53 IF $DATA(^TMP("OCXCMP",$JOB,"INCLUDE",SUBR))
SET OCXSR("CALLS",SUBR)=""
End DoDot:3
End DoDot:2
+54 SET OCXSR("SIZE")=SIZE
+55 KILL ^TMP("OCXCMP",$JOB,"INCLUDE",OCXNAME)
+56 MERGE ^TMP("OCXCMP",$JOB,"INCLUDE",OCXNAME)=OCXSR
End DoDot:1
+57 ;
+58 QUIT 0
+59 ;
REINDEX(ARRAY,NDX2) ;
+1 ;
+2 NEW TEMP,NDX1
MERGE TEMP=ARRAY
KILL ARRAY
+3 SET NDX1=""
FOR
SET NDX1=$ORDER(TEMP(NDX1))
if '$LENGTH(NDX1)
QUIT
Begin DoDot:1
+4 IF $LENGTH(TEMP(NDX1,0))
SET NDX2=NDX2+1
MERGE ARRAY(NDX2)=TEMP(NDX1)
End DoDot:1
+5 QUIT
+6 ;
