close Warning: Can't use blame annotator: 
svn blame failed on WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCK101.m: 'GenericSWIGWrapper' object has no attribute '_wrap'

source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORCK101.m@ 861

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

initial load of WorldVistAEHR
File size: 7.7 KB
RevLine 
1ORCK101 ;SLC/JFR-OR 49 CHECK UTILITIES ;7/27/98
2 ;;2.5;ORDER ENTRY/RESULTS REPORTING;**49**;Jan 08, 1993
3TOP ; from patch options
4 N ORTOP,%ZIS,IOP,TAG
5 W !,"Select the printer to which the reports will be queued:",!
6 S IOP="Q",%ZIS="N"
7 D ^%ZIS
8 I POP W !,"That device is not available or none selected" Q
9 I '$D(IO("Q")) W !!,"The reports must be queued!",! G TOP
10 S ORTOP=1 W !!,"Reports will be sent to ",ION
11 F TAG="PKGFL","PROT","NMSP","XACTION" D
12 . S ZTRTN=TAG_"^ORCK101",ZTDESC="OR*2.5*49 PROTOCOL CHECK"
13 . S ZTDTH=$H,ZTSAVE("ORTOP")="",ZTIO=ION
14 . D ^%ZTLOAD
15 D HOME^%ZIS
16 K ZTSK,ZTIO,ZTDTH,ZTDESC,ZTRTN,ZTSAVE
17 Q
18XACTION ;check extended actions for column width
19 I $D(ZTQUEUED) S ZTREQ="@"
20 N ORIEN,CTR,TMPGBL,CHECK
21 S CHECK="Extended Action Order Set check",TMPGBL="ORXACT"
22 S (CTR,ORIEN)=0
23 F S ORIEN=$O(^ORD(101,ORIEN)) Q:'ORIEN I $P($G(^(ORIEN,0)),U,4)="X" D
24 . Q:'+$G(^ORD(101,ORIEN,4)) S CTR=CTR+1
25 . S ^TMP(TMPGBL,$J,CTR)=$P(^ORD(101,ORIEN,0),U)_" has the COLUMN WIDTH field defined"
26 I '$D(ORTOP) D DEVICE Q ;ok to call linetag
27 D PRINT
28 Q
29PKGFL ;check file 9.4 for duplicates
30 I $D(ZTQUEUED) S ZTREQ="@"
31 N PKG,CHECK,I,N,P,NM,PREF,TMPGBL,CTR
32 S CTR=0,CHECK="PACKAGE (#9.4) file check",TMPGBL="ORPKG"
33 F I=1:1 S PKG=$P($T(LIST+I),";;",2) Q:PKG="QUIT" D
34 . S NM=$P(PKG,"^"),PREF=$P(PKG,"^",2)
35 . S N=$O(^DIC(9.4,"B",NM,0)) D:'N S N=$O(^DIC(9.4,"B",NM,N)) I N D
36 .. S CTR=CTR+1
37 .. S ^TMP(TMPGBL,$J,CTR)=NM_" has "_$S(N:"a duplicate",1:"no")_" name entry in the PACKAGE file"
38 .. Q
39 . S P=$O(^DIC(9.4,"C",PREF,0)) D:'P S P=$O(^DIC(9.4,"C",PREF,P)) I P D
40 .. S CTR=CTR+1
41 .. S ^TMP(TMPGBL,$J,CTR)="There is "_$S(P:"a duplicate",1:"no")_" prefix entry of "_PREF_" in the PACKAGE file"
42 .. Q
43 . I $O(^DIC(9.4,"B",NM,0))'=$O(^DIC(9.4,"C",PREF,0)) D
44 .. S CTR=CTR+1
45 .. S ^TMP(TMPGBL,$J,CTR)="The name and prefix for "_NM_" are not part of the same entry"
46 . Q
47 I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
48 D PRINT
49 Q
50LIST ;list to check
51 ;;LAB SERVICE^LR
52 ;;INPATIENT MEDICATIONS^PSJ
53 ;;OUTPATIENT PHARMACY^PSO
54 ;;DIETETICS^FH
55 ;;RADIOLOGY/NUCLEAR MEDICINE^RA
56 ;;NURSING SERVICE^NUR
57 ;;GEN. MED. REC. - VITALS^GMRV
58 ;;ORDER ENTRY/RESULTS REPORTING^OR
59 ;;QUIT
60PROT ;LOOP 101 AND LOOK AT 10 FIELD FOR DUPS
61 I $D(ZTQUEUED) S ZTREQ="@"
62 N TMPGBL,CTR,PTR,CTR1,ORZIEN,ORZ10IEN
63 S (CTR1,ORZIEN)=0,TMPGBL="ORDUPS"
64 S CHECK="Duplicate Items in PROTOCOL file check"
65 F S ORZIEN=$O(^ORD(101,ORZIEN)) Q:'ORZIEN D:$P(^(ORZIEN,0),"^",4)="D"
66 . S ORZ10IEN=0
67 . F S ORZ10IEN=$O(^ORD(101,ORZIEN,10,"B",ORZ10IEN)) Q:'ORZ10IEN D
68 . . S (PTR,CTR)=0
69 . . F S PTR=$O(^ORD(101,ORZIEN,10,"B",ORZ10IEN,PTR)) Q:'PTR D
70 . . . S CTR=CTR+1 I CTR>1 S CTR1=CTR1+1
71 . . . I S ^TMP(TMPGBL,$J,CTR1)=$P(^ORD(101,ORZIEN,0),U)
72 . . Q
73 . Q
74 I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
75 D PRINT
76 Q
77DLG ; FIND DUPS IN FILE 101.41
78 N TMPGBL,CTR,PTR,CTR1,ORZIEN,ORZ10IEN
79 S (CTR1,ORZIEN)=0,TMPGBL="ORDLGDUP"
80 S CHECK="Duplicate Items in ORDER DIALOG file"
81 F S ORZIEN=$O(^ORD(101.41,ORZIEN)) Q:'ORZIEN D:$P(^(ORZIEN,0),"^",4)="D"
82 . S ORZ10IEN=0
83 . F S ORZ10IEN=$O(^ORD(101.41,ORZIEN,10,"D",ORZ10IEN)) Q:'ORZ10IEN D
84 . . S (PTR,CTR)=0
85 . . F S PTR=$O(^ORD(101.41,ORZIEN,10,"D",ORZ10IEN,PTR)) Q:'PTR D
86 . . . S CTR=CTR+1 I CTR>1 S CTR1=CTR1+1
87 . . . I S ^TMP(TMPGBL,$J,CTR1)=$P(^ORD(101.41,ORZIEN,0),U)
88 . . Q
89 . Q
90 I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
91 D PRINT
92 Q
93NMSP ;loop to find protocols with improper namespace
94 I $D(ZTQUEUED) S ZTREQ="@"
95 D DT^DICRW
96 N CTR,CHECK,TMPGBL,ORZIEN,PKG,GMRC,DIC,X,Y,BADPK,ORZNM,ORZPKG
97 S DIC=9.4,DIC(0)="XM",BADPK=0
98 F X="FH","GMRC","GMRV","LR","PSJ","RA" Q:(BADPK) D
99 . D ^DIC I +Y<0 S BADPK=1 Q
100 . S PKG(+Y)=X I X="GMRC" S GMRC=+Y
101 I BADPK D
102 . S ^TMP("ORPROT",$J,1)="The PACKAGE file should be checked for duplicate entries or PREFIXES."
103 . S ^TMP("ORPROT",$J,2)="Unable to continue namespace check."
104 . S ^TMP("ORPROT",$J,3)=" "
105 . S ^TMP("ORPROT",$J,4)="This review should be repeated after the PACKAGE file is corrected."
106 S (CTR,ORZIEN)=0
107 S TMPGBL="ORPROT",CHECK="Protocol namespace check"
108 I 'BADPK F S ORZIEN=$O(^ORD(101,ORZIEN)) Q:'ORZIEN D
109 . I "QXM"[$P(^ORD(101,ORZIEN,0),"^",4) Q ; don't check menus / ord sets
110 . S ORZPKG=$P(^ORD(101,ORZIEN,0),"^",12) Q:'ORZPKG Q:'$D(PKG(ORZPKG))
111 . I ORZPKG=GMRC Q:'$$OK(ORZIEN) ;special names for consults
112 . S ORZNM=$E($P(^ORD(101,ORZIEN,0),U),1,$S(ORZPKG=GMRC:5,1:$L(PKG(ORZPKG))))
113 . I '$S(ORZPKG=GMRC:"GMRCTGMRCR"[ORZNM,1:ORZNM=PKG(ORZPKG)) D
114 . . S CTR=CTR+1
115 . . S ^TMP(TMPGBL,$J,CTR)=$P(^ORD(101,ORZIEN,0),U)
116 . . Q
117 . Q
118 I '$D(ORTOP) D DEVICE Q ;ok to call from linetag
119 D PRINT
120 Q
121OK(PROT) ;only check ordering protocols
122 I $P(^ORD(101,PROT,0),U,3)'="O" Q 0
123 I $P(^ORD(101,PROT,0),U)["PLACE" Q 0
124 I $P(^ORD(101,PROT,0),U)["URGENCY" Q 0
125 I $P(^ORD(101,PROT,0),U)["GMRCO" Q 0
126 Q 1
127PRINT ;the results are in
128 N CTR,DONE
129 U IO
130 I '$D(^TMP(TMPGBL,$J)) S ^TMP(TMPGBL,$J,1)="No problems with "_CHECK
131 W:$E(IOST,1,2)="C-" @IOF
132 D PAGE(0)
133 S CTR=0 F S CTR=$O(^TMP(TMPGBL,$J,CTR)) Q:'CTR!($D(DONE)) D
134 . I $Y>(IOSL-5) D PAGE(1) Q:$G(DONE)
135 . W !,^TMP(TMPGBL,$J,CTR)
136 . Q
137 D ^%ZISC K CTR,DONE,ORTOP
138CLEAN ;sweep up
139 K ^TMP(TMPGBL,$J)
140 K TMPGBL,CHECK
141 Q
142FIND ; FIND ITEMS IN 101 AND THEIR POSITION
143 N DIC,ITEM,MEN,X,Y,ITPOS
144 D DT^DICRW
145 K DIC S DIC=101,DIC(0)="AEMNQ" D ^DIC
146 I $D(DUOUT)!($D(DTOUT)) Q
147 W !!,$P($G(^ORD(101,+Y,0)),"^")
148 I '$D(^ORD(101,"AD",+Y)) W !,?3,"Not contained on any menus!" QUIT
149 S ITEM=+Y
150 S MEN=0 F S MEN=$O(^ORD(101,"AD",ITEM,MEN)) Q:'MEN D
151 . W !,?5,"is part of ",$P($G(^ORD(101,MEN,0)),"^")
152 . S ITPOS=$$FINDXUTL^ORCMEDT1(MEN,ITEM)
153 . W ?50,"Column: ",$P(ITPOS,".",2),?65,"Row: ",$P(ITPOS,".")
154 . Q
155 Q
156EST ; estimate global growth in ^OR and ^PSRX
157 W !,"Select the printer to which the estimate will be sent:",!
158 S IOP="Q",%ZIS="N"
159 D ^%ZIS
160 I POP W !,"That device is not available or none selected" Q
161 I '$D(IO("Q")) D G EST
162 . W !!,"The estimate may take some time. It must be queued!",!
163 S ZTRTN="QGROW^ORCK101",ZTDESC="Estimate of CPRS global growth"
164 S ZTIO=ION,ZTDTH=$H D ^%ZTLOAD
165 W !!,$S($G(ZTSK):("Task # "_ZTSK),1:"Unable to queue,try later!")
166 D HOME^%ZIS
167 K %ZIS,POP,ZTDESC,ZTIO,ZTRTN,ZTSK
168 Q
169QGROW ;task to do estimate
170 S ZTREQ="@"
171 S BKFILL=$$PSOBKFL
172 S ORENT=$P(^OR(100,0),"^",4),RXENT=$P(^PSRX(0),"^",4)
173 S ORBLK=(ORENT+BKFILL)*($S(^%ZOSF("OS")="DSM":.71,1:.35))
174 S RXBLK=RXENT*($S(^%ZOSF("OS")="DSM":.67,1:.37))
175 U IO
176 W !,"Estimate of global growth from CPRS Installation",!
177 F DASH=1:1:78 W "-"
178 W !!,"Based on the number of entries currently in the ^PSRX and ^OR globals,"
179 W !,"the following are estimates of post-installion requirements."
180 W !,"The globals will continue to grow as implementation of CPRS proceeds"
181 W !!,"The ^PSRX global will require approximately ",RXBLK," blocks."
182 W !!,"Approximately ",BKFILL," prescriptions will be backfilled into the ORDER (#100) file."
183 W !!,"The ^OR global will require approximately ",ORBLK," blocks."
184 K BKFILL,DASH,ORBLK,ORENT,RXBLK,RXENT
185 Q
186PAGE(FEED) ; FEED ONE
187 N DASH,DIR
188 I FEED,$E(IOST,1,2)["C-" S DIR(0)="E" D ^DIR I Y<1 S DONE=1 Q
189 W:FEED @IOF
190 W "OR*2.5*49 - ",CHECK
191 W ! F DASH=1:1:78 W "-"
192 Q
193DEVICE ;
194 S %ZIS="QM" D ^%ZIS I POP D CLEAN Q
195 I $D(IO("Q")) D QUE,^%ZISC,CLEAN Q
196 D PRINT
197 Q
198QUE ; send to TM
199 S ZTSAVE("^TMP(TMPGBL,$J,")="",ZTSAVE("TMPGBL")="",ZTSAVE("CHECK")=""
200 S ZTDTH=$H,ZTDESC="OR*2.5*49 Protocol examination"
201 S ZTRTN="PRINT^ORCK101"
202 S ZTIO=IO
203 D ^%ZTLOAD
204 K ZTSK,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH
205 Q
206PSOBKFL() ;estimate # of RX's to be backfilled into ^OR
207 ; Thks to Ron R.
208 N PDFN,PSD,PSIN,PSODATE,PSOTOT,X,X1,X2
209 S X1=DT,X2=-121 D C^%DTC S PSODATE=X
210 S PSOTOT=0
211 F PDFN=0:0 S PDFN=$O(^PS(55,PDFN)) Q:'PDFN D
212 .F PSD=PSODATE:0 S PSD=$O(^PS(55,PDFN,"P","A",PSD)) Q:'PSD F PSIN=0:0 S PSIN=$O(^PS(55,PDFN,"P","A",PSD,PSIN)) Q:'PSIN I $D(^PSRX(PSIN,0)) D
213 ..I $P($G(^PSRX(PSIN,0)),"^",15)=13!($P($G(^(0)),"^",15)=10)!('$P($G(^(0)),"^",2)) Q
214 ..S PSOTOT=PSOTOT+1
215 Q PSOTOT
Note: See TracBrowser for help on using the repository browser.