source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORY244.m@ 1476

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

initial load of WorldVistAEHR
File size: 7.6 KB
Line 
1ORY244 ;SLC/JEH -- post-install for OR*3*244 ;12/14/2005
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**244**;Dec 17, 1997;Build 1
3 ; Variables used:
4 ; DATE = the date 2nd part of the sub script of LRO(69,DATE
5 ; LORSN = the multiple counter of 69 or 4th part to get to each LAB ORDER
6 ; LABDFN = DFN of LR file
7 ; TSTCNT = the sub multiple / counter of the lab test or the 6th part of the 69 sub script
8 ; OERRDFN = DFN of OR(100
9 ; LRSUB = sub of LAB(60, the lab test in LR
10 ; L60DFN = DFN of Lab test performed
11 ; TSTCNT = 6th part of sub script of LOR(69, pts to LAB TEST( LAB(60, and corresponding OR DFN
12 ; TSTTYP= CH MI AP, from the order file OR(100
13 ; PANEL=1 Indicates from a panel test versies single test PANEL=""
14 ; CNT244 = Number of Abnormal results modified
15 ;
16 ;
17POST ; -- Postinit corrects the abnormal flag and resuslts set in the OR(100, file
18 N DATE,LOCATION,PTNAME,LABDFN,LORSN,LRSUB,TSTCNT,PANEL,TSTTYP,LRIVDAT,LSTEST,LABPNUM,TEST
19 N L60DFN,RCNT,LRRESULT,LV60TST,OERRDFN,OR0,ORESULTS,CNT244,DAT60LV1,DAT60LV2,DAT69LV1,DAT69LV2
20 S LOCATION="",PTNAME="",LABDFN="",PANEL="",CNT244=0,TEST=""
21 K ^TMP("ORFIX",$J),^TMP("ORTXT",$J)
22 S ^TMP("ORFIX",$J,0)=0
23 ;
24PTR69 ; -- Loop thru Lab order file 69 to find ptr to Order file (OR 100) and Lab Data file (LR
25 N ORMSG,ZTSK
26 S ORMSG(1)=""
27 S ORMSG(2)="STARTING reinstatement of missing abnormal results in the ORDER file #100"
28 S ORMSG(3)=""
29 D MES^XPDUTL(.ORMSG)
30 ;W !,"STARTING reinstatement of missing abnormal results in the ORDER file #100"
31 S DATE=3050815 ; PROBLEM START WITH LR*5.2*340 given to test sites Aug 15
32 F S DATE=$O(^LRO(69,DATE)) Q:DATE'?7N!(DATE>3051231) D ;69 loop
33 . ;
34 . S LORSN=0
35 . F S LORSN=$O(^LRO(69,DATE,1,LORSN)) Q:LORSN'>0 D ;loop within LR order to get multi test
36 . . ;
37 . . S DAT69LV1=$G(^LRO(69,DATE,1,LORSN,0)) Q:DAT69LV1=""
38 . . S LABDFN=$P(^LRO(69,DATE,1,LORSN,0),"^",1) ;get LR DFN
39 . . I LABDFN="" Q ;No LR not need to process v2
40 . . ;
41 . . S TSTCNT=0
42 . . F S TSTCNT=$O(^LRO(69,DATE,1,LORSN,2,TSTCNT)) Q:TSTCNT=""!(TSTCNT]"@") D ;loop thru test
43 . . . ;
44 . . . W "."
45 . . . S DAT69LV2=$G(^LRO(69,DATE,1,LORSN,2,TSTCNT,0)) Q:DAT69LV2=""
46 . . . S OERRDFN=$P(^LRO(69,DATE,1,LORSN,2,TSTCNT,0),"^",7) ;get DFN of OR(100
47 . . . I OERRDFN="" Q ;No OR(100 no need to process v2
48 . . . S L60DFN=+$P(^LRO(69,DATE,1,LORSN,2,TSTCNT,0),"^",1) ;get DFN of 60 lab test performed
49 . . . I L60DFN="" Q ;No lab test no need to process v2
50 . . . ; If test is a Panel of test or a single test?
51 . . . S DAT60LV1=$G(^LAB(60,L60DFN,0)) Q:DAT60LV1=""
52 . . . S LSTEST=L60DFN
53 . . . S PANEL=""
54 . . . S PANEL=$G(^LAB(60,L60DFN,2,1,0)) ;if there, equal to 1st test in panel test.
55 . . . I PANEL'="" S PANEL=L60DFN
56 . . . ; OR100FU GET INFO FROM OR(100
57 . . . I $G(^OR(100,OERRDFN,7))="" Q ;No results no need to process
58 . . . I $P(^OR(100,OERRDFN,7),"^",2)=1 Q ;If abnomal results already, no need to process
59 . . . ;
60 . . . S LRIVDAT="",TSTTYP="",ORESULTS=""
61 . . . I $G(^OR(100,OERRDFN,4))="" Q ;If no date time of type quit v3
62 . . . S LRIVDAT=$P(^OR(100,OERRDFN,4),";",5)
63 . . . S TSTTYP=$P(^OR(100,OERRDFN,4),";",4)
64 . . . ;If not one of the Lab test types processed by LR7OR1 then quit
65 . . . I TSTTYP'="CH" Q
66 . . . I LRIVDAT="" Q ;No LR date no need to process v2
67 . . . I PANEL="" D NONPAN
68 . . . ;
69 . . . I PANEL'="" D PAN60 ; PROCESS A PANEL OF TEST FOR THSI ORDER.
70 ;
71 D MAIL
72 ;W !,"Up date of Order file is complete!"
73 ;W !,"Please check your Mail for a list of modified ORDER files"
74 N ORMSG,ZTSK
75 S ORMSG(1)=""
76 S ORMSG(2)="Up date of Order file is complete!"
77 S ORMSG(3)="Please check your Mail for a list of modified ORDER files"
78 S ORMSG(4)=""
79 D MES^XPDUTL(.ORMSG)
80 Q
81 ;
82NONPAN ;
83 S DAT60LV2=$G(^LAB(60,L60DFN,.2)) Q:DAT60LV2=""
84 S LRSUB=$P(^LAB(60,L60DFN,.2),"^",1)
85 I LRSUB="" Q ; if not test skip v2
86 S LRRESULT=$G(^LR(LABDFN,TSTTYP,LRIVDAT,LRSUB)) Q:LRRESULT="" ;If no results quit
87 S TEST=$P(LRRESULT,"^",2)
88 I (TEST["L")!(TEST["H") D Q
89 . I $G(^LAB(60,L60DFN,.1))="" Q ;If no test name quit v3
90 . S ORESULTS=$P(^LAB(60,L60DFN,.1),"^",1)_"="_$P(LRRESULT,"^",1)
91 . D ORUPDAT ;set ABNORMAL results in Order file
92 Q
93 ;
94PAN60 ;
95 S ORESULTS="" ;Clear for the next order file
96 ; S DAT60LV1=$G(^LAB(60,LRSUB,0)) Q:DAT60LV1=""
97 ;
98 ; Lab(60 DFN in LOR(69 was a Panel of test.
99 ; If an abnormal test in the panel test loop thru the panel test to pull each individual test
100 ; also loop Thru the LR from the start to pull the results to put with the test from LAB(60
101 S LRSUB=""
102 ; Loop Thru LR file to pull individual test results when from a panel of test.
103 S RCNT=0
104 S LSTEST=""
105 S LABPNUM=0
106 F S LABPNUM=$O(^LAB(60,PANEL,2,LABPNUM)) Q:LABPNUM=""!(LABPNUM]"@") D
107 . S LV60TST=$G(^LAB(60,PANEL,2,LABPNUM,0)) Q:LV60TST=""
108 . S L60DFN=$P(LV60TST,"^",1)
109 . I L60DFN="" Q ;If not test skip v3
110 . S LRSUB=$G(^LAB(60,L60DFN,.2)) ; If L60DFN not null but not valid quit v3
111 . I LRSUB="" Q ; v3
112 . S LRSUB=$P(^LAB(60,L60DFN,.2),"^",1)
113 . S LRRESULT=$G(^LR(LABDFN,TSTTYP,LRIVDAT,LRSUB)) Q:LRRESULT="" ;If no test quit
114 . S TEST=$P(LRRESULT,"^",2) Q:LRRESULT="" ;If no results quit
115 . I (TEST["L")!(TEST["H") D Q
116 . . S RCNT=RCNT+1
117 . . S DAT60LV1=$G(^LAB(60,L60DFN,0)) Q:DAT60LV1=""
118 . . S LSTEST=LRSUB
119 . . I $G(^LAB(60,L60DFN,.1))="" Q ;If no test name quit v3
120 . . S $P(ORESULTS,",",RCNT)=$P(^LAB(60,L60DFN,.1),"^",1)_"="_$P(LRRESULT,"^",1)_" "
121 . . ; S LRSUB=LRSUB+1 ;Bump to the next LR test results
122 I ORESULTS'="" D ORUPDAT ;set ABNORMAL results in Order file
123 Q
124 ;
125ORUPDAT ; Update the OR(100, file Abnormal results
126 ;
127 S CNT244=CNT244+1
128 S ^TMP("ORFIX",$J,0)=CNT244
129 S PTNAME=""
130 S OR0=$G(^OR(100,OERRDFN,0))
131 S PTNAME=$$PTNM($P(OR0,U,2))
132 S ^TMP("ORFIX",$J,CNT244)="PATIENT NAME="_PTNAME
133 S ^TMP("ORFIX",$J,CNT244,0)=" ORER FILE DFN="_OERRDFN
134 S ^TMP("ORFIX",$J,CNT244,1)=" LAB DATA LRDFN="_LABDFN
135 I PANEL="" S ^TMP("ORFIX",$J,CNT244,2)=" LABORATORY TEST IEN="_LSTEST
136 I PANEL'="" S ^TMP("ORFIX",$J,CNT244,2)=" LABORATORY TEST(PANEL) IEN="_PANEL
137 S ^TMP("ORFIX",$J,CNT244,3)=" ABNORMAL TEST RESULTS: "_ORESULTS
138 S $P(^OR(100,OERRDFN,7),"^",2)=1
139 S $P(^OR(100,OERRDFN,7),"^",3)=ORESULTS
140 ;W !," ABNORMAL TEST RESULTS: ",ORESULTS
141 ;
142 ;S THISTEST=^OR(100,OERRDFN,7)
143 ;W !,"Before update ^OR(100,"_OERRDFN_",7)=",THISTEST
144 ;
145 ;S THISTEST=^OR(100,OERRDFN,7)
146 ;W !,"After update ^OR(100,"_OERRDFN_",7)=",THISTEST
147 ;W !
148 Q
149 ;
150 ;
151 ;
152MAIL ;Send results of cleanup in a mail message to initiator
153 N I,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM
154 S XMSUB="Patch OR*3*244 Clean up completed"
155 S XMDUZ="Patch OR*3*244 Clean up job"
156 S XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
157 S XMTEXT="^TMP(""ORTXT"",$J,"
158 K ^TMP("ORTXT",$J)
159 ; set up header and count
160 S I=1
161 S ^TMP("ORTXT",$J,I)="The reinstatement of Abnormal results has completed.",I=I+1
162 S ^TMP("ORTXT",$J,I)="Below is a listing of Abnormal results taken from Lab test and added to the Order file.",I=I+1
163 S ^TMP("ORTXT",$J,I)="",I=I+1
164 S ^TMP("ORTXT",$J,I)=+$P($G(^TMP("ORFIX",$J,0)),U)_" orders had abnormal results added.",I=I+1
165 S ^TMP("ORTXT",$J,I)="",I=I+1
166 I $G(^TMP("ORFIX",$J,0))=0 S ^TMP("ORTXT",$J,I)="No changes were made to your database.",I=I+1
167 S ^TMP("ORTXT",$J,I)="",I=I+1
168 ; set up message text
169 S CNT244=0 F S CNT244=$O(^TMP("ORFIX",$J,CNT244)) Q:CNT244="" D
170 .S ^TMP("ORTXT",$J,I)=^TMP("ORFIX",$J,CNT244),I=I+1
171 .S ^TMP("ORTXT",$J,I)=^TMP("ORFIX",$J,CNT244,0),I=I+1
172 .S ^TMP("ORTXT",$J,I)=^TMP("ORFIX",$J,CNT244,1),I=I+1
173 .S ^TMP("ORTXT",$J,I)=^TMP("ORFIX",$J,CNT244,2),I=I+1
174 .S ^TMP("ORTXT",$J,I)=^TMP("ORFIX",$J,CNT244,3),I=I+1
175 .S ^TMP("ORTXT",$J,I)="",I=I+1
176 D ^XMD ;send results
177 Q
178 ;
179PTNM(IEN) ;Return pt name or -1 if unable to determine
180 N DFN,VADM
181 I +IEN=0!(IEN'["DPT") Q -1
182 S DFN=+IEN
183 D ^VADPT
184 I $G(VADM(1))="" Q -1
185 Q $G(VADM(1))
186 ;
Note: See TracBrowser for help on using the repository browser.