| 1 | OCXOCMPS ;SLC/RJS,CLA - ORDER CHECK CODE COMPILER (Screen Code Library) ;8/16/99 09:03
|
|---|
| 2 | ;;3.0;ORDER ENTRY/RESULTS REPORTING;**32**;Dec 17,1997
|
|---|
| 3 | ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
|
|---|
| 4 | ;
|
|---|
| 5 | EN ;
|
|---|
| 6 | ;
|
|---|
| 7 | Q
|
|---|
| 8 | ;
|
|---|
| 9 | OPSCR() ;
|
|---|
| 10 | ;
|
|---|
| 11 | N OCXDT,OCXOPDT
|
|---|
| 12 | S OCXOPDT=$P($G(^OCXS(864.1,+$P(^(0),U,2),0)),U,1)
|
|---|
| 13 | S OCXDT=$$DTYP(+$G(^OCXS(860.3,+$G(DA(1)),"COND",+$G(DA),"DFLD1")))
|
|---|
| 14 | Q:'(OCXDT=OCXOPDT) 0 Q ''$D(^OCXS(863.9,+Y,"PAR","B","OCXO GENERATE CODE FUNCTION"))
|
|---|
| 15 | ;
|
|---|
| 16 | SCFLD(OCXNODE,OCXD0) ;
|
|---|
| 17 | ;
|
|---|
| 18 | ; This subroutine is called from the input transform of
|
|---|
| 19 | ; 'Data Field 1', 'Data Field 2', and 'Data Field 3' of the
|
|---|
| 20 | ; Conditional Expression Sub-Field of the Order Check Element
|
|---|
| 21 | ; file. The naked pointer should therefore be pointing to the
|
|---|
| 22 | ; 'zero' node of the record being processed.
|
|---|
| 23 | ;
|
|---|
| 24 | N CONTXT,LINKS,D0
|
|---|
| 25 | M LINKS=^("LINK")
|
|---|
| 26 | S CONTXT=$P($G(^OCXS(860.3,OCXD0,0)),U,2)
|
|---|
| 27 | I $D(LINKS(+CONTXT)) Q 1
|
|---|
| 28 | S CONTXT=$O(^OCXS(860.6,"B","DATABASE LOOKUP",0)) Q:'CONTXT 0
|
|---|
| 29 | Q ''$D(LINKS(+CONTXT))
|
|---|
| 30 | ;
|
|---|
| 31 | SOURCE(OCXNODE,D0,D1) ;
|
|---|
| 32 | ;
|
|---|
| 33 | Q ($P(OCXNODE,U,2)=(+$G(^OCXS(860.4,D0,"LINK",D1,0))))
|
|---|
| 34 | ;
|
|---|
| 35 | DTYP(DFLD) ;
|
|---|
| 36 | Q:'DFLD "A"
|
|---|
| 37 | N OCXLINK,OCXATT,OCXDTN,OCXDTYP,OCXX,OCXCON
|
|---|
| 38 | S OCXCON=$O(^OCXS(860.4,+DFLD,"LINK",0)) Q:'OCXCON "AA"
|
|---|
| 39 | S OCXLINK=$G(^OCXS(860.4,+DFLD,"LINK",OCXCON,"DATAPATH")) Q:'$L(OCXLINK) "B"
|
|---|
| 40 | S OCXLINK=$O(^OCXS(863.3,"B",OCXLINK,0)) Q:'OCXLINK "C"
|
|---|
| 41 | S OCXATT=$P($G(^OCXS(863.3,+OCXLINK,0)),U,5) Q:'OCXATT "D"
|
|---|
| 42 | S OCXDTN=$O(^OCXS(863.8,"B","DATA TYPE",0)) Q:'OCXDTN "E"
|
|---|
| 43 | 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)
|
|---|
| 44 | Q:'OCXX "F" Q $G(^OCXS(863.4,OCXATT,"PAR",OCXX,"VAL"))
|
|---|
| 45 | ;
|
|---|
| 46 | LABEL ;
|
|---|
| 47 | N OCXER,OCXX,OCXY,OCXSUB
|
|---|
| 48 | S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 49 | S OCXX=X,OCXER=0
|
|---|
| 50 | I ($L(X)>30)!($L(X)<1) W !," ",$L(OCXX)," characters, Label TOO long... " S OCXER=OCXER+1
|
|---|
| 51 | I (X["(") W !," Illegal punctuation -> '(' " S OCXER=OCXER+1
|
|---|
| 52 | I (X[")") W !," Illegal punctuation -> ')' " S OCXER=OCXER+1
|
|---|
| 53 | S OCXY=$O(^OCXS(860.2,+$G(DA(1)),"C","C",X,0))
|
|---|
| 54 | 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
|
|---|
| 55 | S OCXY=$O(^OCXS(864.1,"B","BOOLEAN",0))
|
|---|
| 56 | I OCXY F OCXSUB="B","AKA" D
|
|---|
| 57 | .N OCXNAM S OCXNAM="" F S OCXNAM=$O(^OCXS(863.9,OCXSUB,OCXNAM)) Q:'$L(OCXNAM) D
|
|---|
| 58 | ..S OCXX=0 F S OCXX=$O(^OCXS(863.9,OCXSUB,OCXNAM,OCXX)) Q:'OCXX D
|
|---|
| 59 | ...N OCXDTYP S OCXDTYP=$P($G(^OCXS(863.9,OCXX,0)),U,2) Q:'(OCXDTYP=OCXY)
|
|---|
| 60 | ...I ((" "_X_" ")[(" "_OCXNAM_" ")) W !," Illegal Reserved word -> '",OCXNAM,"'" S OCXER=OCXER+1
|
|---|
| 61 | I (" "_X_" "[(" IF ")) W !," Illegal Reserved word -> 'IF'" S OCXER=OCXER+1
|
|---|
| 62 | ;
|
|---|
| 63 | I OCXER K X
|
|---|
| 64 | Q
|
|---|
| 65 | ;
|
|---|
