- 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 Feb 18, 2025@23:51:32 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 ;
