source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY2431.m@ 1177

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

initial load of WorldVistAEHR
File size: 5.7 KB
RevLine 
[613]1ORY2431 ;SLC/RJS,CLA - OCX PACKAGE RULE TRANSPORT ROUTINE (Delete after Install of OR*3*243) ;NOV 2,2006 at 12:05
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243**;Dec 17,1997;Build 242
3 ;; ;;ORDER CHECK EXPERT version 1.01 released OCT 29,1998
4 ;
5S ;
6 ;
7 Q
8 ;
9 ;
10COMPARE(L,R) ;
11 ;
12 Q:$$RES("R") 1
13 ;
14 Q:'$L($O(L(""))) $$ADDREC^ORY2432("R")
15 ;
16 N C,OCXDD M C=L,C=R S OCXDD=$O(C("")) Q $$MULT("C",OCXDD)
17 ;
18 Q 0
19 ;
20RES(REF) ;
21 ;
22 N QUIT,SUB
23 S QUIT=0
24 S SUB="" F S SUB=$O(@REF@(SUB)) Q:'$L(SUB) I (SUB[":") D Q:QUIT
25 .N DD,DA
26 .S DD=$P(SUB,":",1),DA=$P(SUB,":",2)
27 .I $L(DA),'(DA=+DA) D Q:QUIT
28 ..N DANEW,SUBNEW
29 ..S DANEW=$O(^OCXS($P(DA,U,2),"B",$P(DA,U,1),0))
30 ..I 'DANEW W !!,$P($G(^OCXS(+$P(DA,U,2),0)),U,1),": ",$P(DA,U,1)," could not resolve name.",!!," End Transport." S QUIT=1 Q
31 ..S SUBNEW=DD_":"_DANEW
32 ..I $D(@REF@(SUBNEW)) W !!," multiple #",DANEW," already existed." S QUIT=1 Q
33 ..M @REF@(SUBNEW)=@REF@(SUB)
34 ..K @REF@(SUB)
35 ..S SUB=""
36 .I $L(SUB),($D(@REF@(SUB))>9) S QUIT=$$RES($NA(@REF@(SUB)))
37 ;
38 Q QUIT
39 ;
40MULT(CREF,OCXDD) ;
41 ;
42 N OCXSUB,LREF,RREF,QUIT,OCXFLD
43 S LREF="L"_$E(CREF,2,$L(CREF)),RREF="R"_$E(CREF,2,$L(CREF))
44 ;
45 S QUIT=0,OCXFLD="" F S OCXFLD=$O(@CREF@(OCXDD,OCXFLD)) Q:'$L(OCXFLD) D Q:QUIT
46 .I (OCXFLD[":") D Q:QUIT
47 ..Q:$$EXFLD(+OCXFLD,0)
48 ..I '$D(@LREF@(OCXDD,OCXFLD,.01,"E")) D M @LREF@(OCXDD,OCXFLD)=@RREF@(OCXDD,OCXFLD)
49 ...D WARN("Missing multiple:",CREF,OCXDD,OCXFLD)
50 ...S QUIT=$$ADDMULT^ORY2433(CREF,OCXDD,OCXFLD)
51 ..I '$D(@RREF@(OCXDD,OCXFLD,.01,"E")) D M @RREF@(OCXDD,OCXFLD)=@LREF@(OCXDD,OCXFLD)
52 ...D WARN("Extra multiple:",CREF,OCXDD,OCXFLD)
53 ...S QUIT=$$DELMULT^ORY2433($$APPEND(CREF,OCXDD),OCXFLD)
54 .;
55 .I (OCXFLD=+OCXFLD),'$$EXFLD(+OCXDD,OCXFLD) D
56 ..I ($O(@CREF@(OCXDD,OCXFLD,""))="E") D Q
57 ...I $L($G(@RREF@(OCXDD,OCXFLD,"E"))),'$L($G(@LREF@(OCXDD,OCXFLD,"E"))) D Q
58 ....D WARN("Data Value Missing in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E")
59 ....S QUIT=$$EDITFLD^ORY2434(CREF,OCXDD,OCXFLD,"E")
60 ...I $L($G(@LREF@(OCXDD,OCXFLD,"E"))),'$L($G(@RREF@(OCXDD,OCXFLD,"E"))) D Q
61 ....D WARN("Extra Data Value in "_$$NETNAME^OCXSEND,CREF,OCXDD,OCXFLD,"E")
62 ....S QUIT=$$DELFLD^ORY2434(CREF,OCXDD,OCXFLD,"E")
63 ...I '(@LREF@(OCXDD,OCXFLD,"E")=@RREF@(OCXDD,OCXFLD,"E")) D
64 ....D WARN("Inconsistent Data",CREF,OCXDD,OCXFLD,"E")
65 ....S QUIT=$$EDITFLD^ORY2434(CREF,OCXDD,OCXFLD,"E")
66 ..S OCXSUB=0 F Q:QUIT S OCXSUB=$O(@CREF@(OCXDD,OCXFLD,OCXSUB)) Q:'OCXSUB I '($G(@RREF@(OCXDD,OCXFLD,OCXSUB))=$G(@LREF@(OCXDD,OCXFLD,OCXSUB))) D Q
67 ...D WARN("Inconsistent word Data",CREF,OCXDD,OCXFLD,OCXSUB)
68 ...S QUIT=$$LOADWORD^ORY2432(RREF,OCXDD,OCXFLD,OCXSUB)
69 .;
70 .I 'QUIT,(OCXFLD[":") S QUIT=$$MULT($$APPEND(CREF,OCXDD),OCXFLD)
71 Q QUIT
72 ;
73APPEND(ARRAY,OCXSUB) ;
74 S:'(OCXSUB=+OCXSUB) OCXSUB=""""_OCXSUB_""""
75 Q:'(ARRAY["(") ARRAY_"("_OCXSUB_")"
76 Q $E(ARRAY,1,$L(ARRAY)-1)_","_OCXSUB_")"
77 ;
78EXFLD(FILE,OCXFLD) ;
79 N OCXFNAM
80 S OCXFNAM=$$FIELD^OCXSENDD(FILE,OCXFLD,"LABEL")
81 I (OCXFNAM["UNIQUE OBJECT IDENTIFIER") Q 1
82 I (FILE=860.2),(OCXFLD=.02) Q 1
83 I (FILE=860.22),(OCXFLD=4) Q 1
84 I (FILE=860.3),(OCXFLD=3) Q 1
85 I (FILE=860.9),(OCXFLD=1) Q 1
86 I (FILE=860.91) Q 1
87 I (FILE=860.801) Q 1
88 I (FILE=860.81) Q 1
89 I (FILE=861.01) Q 1
90 I (FILE=863.02) Q 1
91 I (FILE=863.54) Q 1
92 I (FILE=863.61) Q 1
93 I (FILE=863.72) Q 1
94 I (FILE=863.81) Q 1
95 I ($E(OCXFNAM,1)="*") Q 1
96 Q 0
97 ;
98WARN(MSG,CREF,OCXDD,OCXFLD,OCXSUB) ;
99 ;
100 Q:$G(OCXAUTO)
101 ;
102 N D0,DASH,OCXDDPTH,OCXDPTR,FILE,FILEID,LREF,OCXPTR,RREF
103 ;
104 S DASH="",$P(DASH,"-",(55-$L(MSG)))="-"
105 W !!,"------------",MSG,DASH
106 D DSPHDR(CREF,OCXDD,OCXFLD)
107 I $D(OCXSUB) D DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB)
108 I '$D(OCXSUB) D DSPREC(CREF,OCXDD,OCXFLD)
109 ;
110 W ! Q
111 ;
112DSPREC(CREF,OCXDD,OCXFLD) ;
113 ;
114 N OCXDPTR,OCXDDPTH,LEVL,OCXCREF,OCXSUB
115 S OCXCREF=$$APPEND($$APPEND(CREF,OCXDD),OCXFLD)
116 S OCXDDPTH=$P($P(OCXCREF,"(",2),")",1),LEVL=$L(OCXDDPTH,",")
117 S OCXSUB="" F S OCXSUB=$O(@OCXCREF@(OCXSUB)) Q:'$L(OCXSUB) D
118 .;
119 .I '(OCXSUB[":"),'((OCXSUB=.01)&$O(@OCXCREF@(OCXSUB))) D
120 ..N LINE
121 ..Q:$$EXFLD(+OCXFLD,OCXSUB)
122 ..I OCXFLD W !,?(5+((LEVL)*4)),$$FIELD^OCXSENDD(+OCXFLD,OCXSUB,"LABEL"),": ",$G(@OCXCREF@(OCXSUB,"E"))
123 ..S LINE=0 F S LINE=$O(@OCXCREF@(OCXSUB,LINE)) Q:'LINE D
124 ...W !,?(5+(LEVL*4)),$J(LINE,3),">",@OCXCREF@(OCXSUB,LINE)
125 .;
126 .I (OCXSUB[":") D
127 ..N D0,OCXDD,FILENAME
128 ..S D0=+$P(OCXSUB,":",2),OCXDD=+OCXSUB
129 ..S FILENAME=$$FILENAME^OCXSENDD(OCXDD)
130 ..I $L(FILENAME) W !,?(5+($L(LEVL)*4)),FILENAME
131 ..E W !!,?(5+(LEVL*4)),FILENAME
132 ..W " ",D0,": ",$G(@OCXCREF@(OCXSUB,.01,"E"))
133 ..D DSPREC($$APPEND(CREF,OCXDD),OCXFLD,OCXSUB)
134 ;
135 Q
136 ;
137DSPHDR(CREF,OCXDD,OCXFLD) ;
138 ;
139 N D0,FILE,FILEID,OCXPTR,OCXDDPTH
140 S OCXDDPTH=$P($P($$APPEND($$APPEND(CREF,OCXDD),OCXFLD),"(",2),")",1)
141 S FILE="" F OCXPTR=1:1:$L(OCXDDPTH,",") D
142 .N OCXDD,D0,FILEID
143 .S FILEID=$P(OCXDDPTH,",",OCXPTR)
144 .I (FILEID[":") D
145 ..S D0=+$P(FILEID,":",2),OCXDD=+$E(FILEID,2,$L(FILEID))
146 ..W !,?(5+(OCXPTR*4)),$$FILENAME^OCXSENDD(OCXDD)
147 ..S:$L(FILE) FILE=FILE_"," S FILE=FILE_FILEID
148 ..I $D(@("L("_FILE_",.01,""E"")")) W ": ",@("L("_FILE_",.01,""E"")") W:D0 " [",D0,"]"
149 ..E I $D(@("R("_FILE_",.01,""E"")")) W ": ",@("R("_FILE_",.01,""E"")") W:D0 " [",D0,"]"
150 ;
151 Q
152 ;
153DSPFLD(CREF,OCXDD,OCXFLD,OCXSUB) ;
154 ;
155 N OCXDPTR,LREF,RREF,OCXDDPTH
156 ;
157 S OCXDDPTH=$P($P($$APPEND(CREF,OCXDD),"(",2),")",1)
158 S LREF="L("_OCXDDPTH_")",RREF="R("_OCXDDPTH_")"
159 W !,?(5+(($L(OCXDDPTH,",")+1)*4)),$$FIELD^OCXSENDD(OCXDD,OCXFLD,"LABEL")," field [",OCXFLD,"]"
160 I OCXSUB W " Line #",OCXSUB
161 ;
162 W:($D(@RREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(R) CPRS27.FO-SLC.MED.VA.GOV: ",@RREF@(OCXFLD,OCXSUB)
163 W:($D(@LREF@(OCXFLD,OCXSUB))) !,?(5+(($L(OCXDDPTH,",")+2)*4)),"(L) ",$$NETNAME^OCXSEND,": ",@LREF@(OCXFLD,OCXSUB)
164 ;
165 Q
166 ;
167 W !,?10 Q 0 Q $$PAUSE
168 ;
169PAUSE() W " Press Enter " R X:DTIME W ! Q (X[U)
170 ;
171NOW() N X,Y,%DT S X="N",%DT="T" D ^%DT S Y=$$DATE^OCXSENDD(Y) S:(Y["@") Y=$P(Y,"@",1)_" at "_$P(Y,"@",2) Q Y
172 ;
Note: See TracBrowser for help on using the repository browser.