OCXOCMPN ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Construct Rule MetaCode Subroutines) ;10/29/98 12:37
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
MC(CODE,ELEM) ;
;
N INDEX1,INDEX2,LEVL
;
S INDEX1=0 F S INDEX1=$O(CODE(INDEX1)) Q:'INDEX1 D
.I ($E(CODE(INDEX1),1,10)="I $L(OCXDF") D
..N DFLD S DFLD=(+$P(CODE(INDEX1),"OCXDF(",2))
..D INSERT(INDEX1+1,"S OCXRES("_(+ELEM)_","_(DFLD)_")=OCXDF("_(+DFLD)_")","S")
;
D INSERT(1,";","Y")
S INDEX1=0 F S INDEX1=$O(CODE(INDEX1)) Q:'INDEX1 D
.I ($E(CODE(INDEX1),1,7)="S OCXDF") D
..N DFLD S DFLD=(+$P(CODE(INDEX1),"OCXDF(",2)),INDEX1=INDEX1+1
..D INSERT(1,"; OCXDF("_(+DFLD)_") -> "_$P($G(^OCXS(860.4,+DFLD,0)),U,1)_" data field","Y")
;
S (LEVL,INDEX1)=0 F S INDEX1=$O(CODE(INDEX1)) Q:'INDEX1 D
.I (CODE(INDEX1,"OPLIST")="Y") S LEVL=0 Q
.S INDEX2=INDEX1 F S INDEX2=$O(CODE(INDEX2)) Q:'INDEX2 Q:(CODE(INDEX2,"OPLIST")="Y") D
..;I (($L(CODE(INDEX1))+$L(CODE(INDEX2)))>70) S LEVL=LEVL+1,CODE(INDEX1)=CODE(INDEX1)_" D",CODE(INDEX2)=$E("...........",1,LEVL)_CODE(INDEX2),INDEX2=99999 Q
..I (($L(CODE(INDEX1))+$L(CODE(INDEX2)))>OCXCLL) S LEVL=LEVL+1,CODE(INDEX1)=CODE(INDEX1)_" D",CODE(INDEX2)=$E("...........",1,LEVL)_CODE(INDEX2),INDEX2=99999 Q
..I ($E(CODE(INDEX1,"OPLIST"),$L(CODE(INDEX1,"OPLIST")))=CODE(INDEX2,"OPLIST")) D Q
...S CODE(INDEX1)=CODE(INDEX1)_","_$P(CODE(INDEX2)," ",2,999) K CODE(INDEX2)
..S CODE(INDEX1)=CODE(INDEX1)_" "_CODE(INDEX2)
..S CODE(INDEX1,"OPLIST")=CODE(INDEX1,"OPLIST")_CODE(INDEX2,"OPLIST")
..K CODE(INDEX2)
;
Q
;
INSERT(X,T,O) ;
;
N Y,LAST
S LAST=$O(CODE(99999),-1)
F Y=LAST:-1:X M CODE(Y+1)=CODE(Y)
S CODE(X)=T
S CODE(X,"OPLIST")=O
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPN 1769 printed Oct 16, 2024@18:25:35 Page 2
OCXOCMPN ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Construct Rule MetaCode Subroutines) ;10/29/98 12:37
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
+2 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
+3 ;
MC(CODE,ELEM) ;
+1 ;
+2 NEW INDEX1,INDEX2,LEVL
+3 ;
+4 SET INDEX1=0
FOR
SET INDEX1=$ORDER(CODE(INDEX1))
if 'INDEX1
QUIT
Begin DoDot:1
+5 IF ($EXTRACT(CODE(INDEX1),1,10)="I $L(OCXDF")
Begin DoDot:2
+6 NEW DFLD
SET DFLD=(+$PIECE(CODE(INDEX1),"OCXDF(",2))
+7 DO INSERT(INDEX1+1,"S OCXRES("_(+ELEM)_","_(DFLD)_")=OCXDF("_(+DFLD)_")","S")
End DoDot:2
End DoDot:1
+8 ;
+9 DO INSERT(1,";","Y")
+10 SET INDEX1=0
FOR
SET INDEX1=$ORDER(CODE(INDEX1))
if 'INDEX1
QUIT
Begin DoDot:1
+11 IF ($EXTRACT(CODE(INDEX1),1,7)="S OCXDF")
Begin DoDot:2
+12 NEW DFLD
SET DFLD=(+$PIECE(CODE(INDEX1),"OCXDF(",2))
SET INDEX1=INDEX1+1
+13 DO INSERT(1,"; OCXDF("_(+DFLD)_") -> "_$PIECE($GET(^OCXS(860.4,+DFLD,0)),U,1)_" data field","Y")
End DoDot:2
End DoDot:1
+14 ;
+15 SET (LEVL,INDEX1)=0
FOR
SET INDEX1=$ORDER(CODE(INDEX1))
if 'INDEX1
QUIT
Begin DoDot:1
+16 IF (CODE(INDEX1,"OPLIST")="Y")
SET LEVL=0
QUIT
+17 SET INDEX2=INDEX1
FOR
SET INDEX2=$ORDER(CODE(INDEX2))
if 'INDEX2
QUIT
if (CODE(INDEX2,"OPLIST")="Y")
QUIT
Begin DoDot:2
+18 ;I (($L(CODE(INDEX1))+$L(CODE(INDEX2)))>70) S LEVL=LEVL+1,CODE(INDEX1)=CODE(INDEX1)_" D",CODE(INDEX2)=$E("...........",1,LEVL)_CODE(INDEX2),INDEX2=99999 Q
+19 IF (($LENGTH(CODE(INDEX1))+$LENGTH(CODE(INDEX2)))>OCXCLL)
SET LEVL=LEVL+1
SET CODE(INDEX1)=CODE(INDEX1)_" D"
SET CODE(INDEX2)=$EXTRACT("...........",1,LEVL)_CODE(INDEX2)
SET INDEX2=99999
QUIT
+20 IF ($EXTRACT(CODE(INDEX1,"OPLIST"),$LENGTH(CODE(INDEX1,"OPLIST")))=CODE(INDEX2,"OPLIST"))
Begin DoDot:3
+21 SET CODE(INDEX1)=CODE(INDEX1)_","_$PIECE(CODE(INDEX2)," ",2,999)
KILL CODE(INDEX2)
End DoDot:3
QUIT
+22 SET CODE(INDEX1)=CODE(INDEX1)_" "_CODE(INDEX2)
+23 SET CODE(INDEX1,"OPLIST")=CODE(INDEX1,"OPLIST")_CODE(INDEX2,"OPLIST")
+24 KILL CODE(INDEX2)
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
INSERT(X,T,O) ;
+1 ;
+2 NEW Y,LAST
+3 SET LAST=$ORDER(CODE(99999),-1)
+4 FOR Y=LAST:-1:X
MERGE CODE(Y+1)=CODE(Y)
+5 SET CODE(X)=T
+6 SET CODE(X,"OPLIST")=O
+7 QUIT
+8 ;
