source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/OCXOCMPS.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 2.6 KB
Line 
1OCXOCMPS ;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 ;
5EN ;
6 ;
7 Q
8 ;
9OPSCR() ;
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 ;
16SCFLD(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 ;
31SOURCE(OCXNODE,D0,D1) ;
32 ;
33 Q ($P(OCXNODE,U,2)=(+$G(^OCXS(860.4,D0,"LINK",D1,0))))
34 ;
35DTYP(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 ;
46LABEL ;
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 ;
Note: See TracBrowser for help on using the repository browser.