OCXOCMPS ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Screen Code Library) ;8/16/99 09:03
;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
;
EN ;
;
Q
;
OPSCR() ;
;
N OCXDT,OCXOPDT
S OCXOPDT=$P($G(^OCXS(864.1,+$P(^(0),U,2),0)),U,1)
S OCXDT=$$DTYP(+$G(^OCXS(860.3,+$G(DA(1)),"COND",+$G(DA),"DFLD1")))
Q:'(OCXDT=OCXOPDT) 0 Q ''$D(^OCXS(863.9,+Y,"PAR","B","OCXO GENERATE CODE FUNCTION"))
;
SCFLD(OCXNODE,OCXD0) ;
;
; This subroutine is called from the input transform of
; 'Data Field 1', 'Data Field 2', and 'Data Field 3' of the
; Conditional Expression Sub-Field of the Order Check Element
; file. The naked pointer should therefore be pointing to the
; 'zero' node of the record being processed.
;
N CONTXT,LINKS,D0
M LINKS=^("LINK")
S CONTXT=$P($G(^OCXS(860.3,OCXD0,0)),U,2)
I $D(LINKS(+CONTXT)) Q 1
S CONTXT=$O(^OCXS(860.6,"B","DATABASE LOOKUP",0)) Q:'CONTXT 0
Q ''$D(LINKS(+CONTXT))
;
SOURCE(OCXNODE,D0,D1) ;
;
Q ($P(OCXNODE,U,2)=(+$G(^OCXS(860.4,D0,"LINK",D1,0))))
;
DTYP(DFLD) ;
Q:'DFLD "A"
N OCXLINK,OCXATT,OCXDTN,OCXDTYP,OCXX,OCXCON
S OCXCON=$O(^OCXS(860.4,+DFLD,"LINK",0)) Q:'OCXCON "AA"
S OCXLINK=$G(^OCXS(860.4,+DFLD,"LINK",OCXCON,"DATAPATH")) Q:'$L(OCXLINK) "B"
S OCXLINK=$O(^OCXS(863.3,"B",OCXLINK,0)) Q:'OCXLINK "C"
S OCXATT=$P($G(^OCXS(863.3,+OCXLINK,0)),U,5) Q:'OCXATT "D"
S OCXDTN=$O(^OCXS(863.8,"B","DATA TYPE",0)) Q:'OCXDTN "E"
S OCXX=0 F S OCXX=$O(^OCXS(863.4,OCXATT,"PAR",OCXX)) Q:'OCXX Q:($P(^OCXS(863.4,OCXATT,"PAR",OCXX,0),U,1)=OCXDTN)
Q:'OCXX "F" Q $G(^OCXS(863.4,OCXATT,"PAR",OCXX,"VAL"))
;
LABEL ;
N OCXER,OCXX,OCXY,OCXSUB
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
S OCXX=X,OCXER=0
I ($L(X)>30)!($L(X)<1) W !," ",$L(OCXX)," characters, Label TOO long... " S OCXER=OCXER+1
I (X["(") W !," Illegal punctuation -> '(' " S OCXER=OCXER+1
I (X[")") W !," Illegal punctuation -> ')' " S OCXER=OCXER+1
S OCXY=$O(^OCXS(860.2,+$G(DA(1)),"C","C",X,0))
I OCXY,'(OCXY=DA) W !," This label already used by another element",!," -> ",$P($G(^OCXS(860.3,+$G(^OCXS(860.2,DA(1),"C",OCXY,0)),0)),U,1) S OCXER=OCXER+1
S OCXY=$O(^OCXS(864.1,"B","BOOLEAN",0))
I OCXY F OCXSUB="B","AKA" D
.N OCXNAM S OCXNAM="" F S OCXNAM=$O(^OCXS(863.9,OCXSUB,OCXNAM)) Q:'$L(OCXNAM) D
..S OCXX=0 F S OCXX=$O(^OCXS(863.9,OCXSUB,OCXNAM,OCXX)) Q:'OCXX D
...N OCXDTYP S OCXDTYP=$P($G(^OCXS(863.9,OCXX,0)),U,2) Q:'(OCXDTYP=OCXY)
...I ((" "_X_" ")[(" "_OCXNAM_" ")) W !," Illegal Reserved word -> '",OCXNAM,"'" S OCXER=OCXER+1
I (" "_X_" "[(" IF ")) W !," Illegal Reserved word -> 'IF'" S OCXER=OCXER+1
;
I OCXER K X
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOCXOCMPS 2728 printed Apr 09, 2024@21:35 Page 2
OCXOCMPS ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Screen Code Library) ;8/16/99 09:03
+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 QUIT
+3 ;
OPSCR() ;
+1 ;
+2 NEW OCXDT,OCXOPDT
+3 SET OCXOPDT=$PIECE($GET(^OCXS(864.1,+$PIECE(^(0),U,2),0)),U,1)
+4 SET OCXDT=$$DTYP(+$GET(^OCXS(860.3,+$GET(DA(1)),"COND",+$GET(DA),"DFLD1")))
+5 if '(OCXDT=OCXOPDT)
QUIT 0
QUIT ''$DATA(^OCXS(863.9,+Y,"PAR","B","OCXO GENERATE CODE FUNCTION"))
+6 ;
SCFLD(OCXNODE,OCXD0) ;
+1 ;
+2 ; This subroutine is called from the input transform of
+3 ; 'Data Field 1', 'Data Field 2', and 'Data Field 3' of the
+4 ; Conditional Expression Sub-Field of the Order Check Element
+5 ; file. The naked pointer should therefore be pointing to the
+6 ; 'zero' node of the record being processed.
+7 ;
+8 NEW CONTXT,LINKS,D0
+9 MERGE LINKS=^("LINK")
+10 SET CONTXT=$PIECE($GET(^OCXS(860.3,OCXD0,0)),U,2)
+11 IF $DATA(LINKS(+CONTXT))
QUIT 1
+12 SET CONTXT=$ORDER(^OCXS(860.6,"B","DATABASE LOOKUP",0))
if 'CONTXT
QUIT 0
+13 QUIT ''$DATA(LINKS(+CONTXT))
+14 ;
SOURCE(OCXNODE,D0,D1) ;
+1 ;
+2 QUIT ($PIECE(OCXNODE,U,2)=(+$GET(^OCXS(860.4,D0,"LINK",D1,0))))
+3 ;
DTYP(DFLD) ;
+1 if 'DFLD
QUIT "A"
+2 NEW OCXLINK,OCXATT,OCXDTN,OCXDTYP,OCXX,OCXCON
+3 SET OCXCON=$ORDER(^OCXS(860.4,+DFLD,"LINK",0))
if 'OCXCON
QUIT "AA"
+4 SET OCXLINK=$GET(^OCXS(860.4,+DFLD,"LINK",OCXCON,"DATAPATH"))
if '$LENGTH(OCXLINK)
QUIT "B"
+5 SET OCXLINK=$ORDER(^OCXS(863.3,"B",OCXLINK,0))
if 'OCXLINK
QUIT "C"
+6 SET OCXATT=$PIECE($GET(^OCXS(863.3,+OCXLINK,0)),U,5)
if 'OCXATT
QUIT "D"
+7 SET OCXDTN=$ORDER(^OCXS(863.8,"B","DATA TYPE",0))
if 'OCXDTN
QUIT "E"
+8 SET OCXX=0
FOR
SET OCXX=$ORDER(^OCXS(863.4,OCXATT,"PAR",OCXX))
if 'OCXX
QUIT
if ($PIECE(^OCXS(863.4,OCXATT,"PAR",OCXX,0),U,1)=OCXDTN)
QUIT
+9 if 'OCXX
QUIT "F"
QUIT $GET(^OCXS(863.4,OCXATT,"PAR",OCXX,"VAL"))
+10 ;
LABEL ;
+1 NEW OCXER,OCXX,OCXY,OCXSUB
+2 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 SET OCXX=X
SET OCXER=0
+4 IF ($LENGTH(X)>30)!($LENGTH(X)<1)
WRITE !," ",$LENGTH(OCXX)," characters, Label TOO long... "
SET OCXER=OCXER+1
+5 IF (X["(")
WRITE !," Illegal punctuation -> '(' "
SET OCXER=OCXER+1
+6 IF (X[")")
WRITE !," Illegal punctuation -> ')' "
SET OCXER=OCXER+1
+7 SET OCXY=$ORDER(^OCXS(860.2,+$GET(DA(1)),"C","C",X,0))
+8 IF OCXY
IF '(OCXY=DA)
WRITE !," This label already used by another element",!," -> ",$PIECE($GET(^OCXS(860.3,+$GET(^OCXS(860.2,DA(1),"C",OCXY,0)),0)),U,1)
SET OCXER=OCXER+1
+9 SET OCXY=$ORDER(^OCXS(864.1,"B","BOOLEAN",0))
+10 IF OCXY
FOR OCXSUB="B","AKA"
Begin DoDot:1
+11 NEW OCXNAM
SET OCXNAM=""
FOR
SET OCXNAM=$ORDER(^OCXS(863.9,OCXSUB,OCXNAM))
if '$LENGTH(OCXNAM)
QUIT
Begin DoDot:2
+12 SET OCXX=0
FOR
SET OCXX=$ORDER(^OCXS(863.9,OCXSUB,OCXNAM,OCXX))
if 'OCXX
QUIT
Begin DoDot:3
+13 NEW OCXDTYP
SET OCXDTYP=$PIECE($GET(^OCXS(863.9,OCXX,0)),U,2)
if '(OCXDTYP=OCXY)
QUIT
+14 IF ((" "_X_" ")[(" "_OCXNAM_" "))
WRITE !," Illegal Reserved word -> '",OCXNAM,"'"
SET OCXER=OCXER+1
End DoDot:3
End DoDot:2
End DoDot:1
+15 IF (" "_X_" "[(" IF "))
WRITE !," Illegal Reserved word -> 'IF'"
SET OCXER=OCXER+1
+16 ;
+17 IF OCXER
KILL X
+18 QUIT
+19 ;
