source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRX.m@ 1006

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

initial load of WorldVistAEHR

File size: 8.4 KB
Line 
1LRX ;SLC/BA/DALISC/FHS - UTILITY ROUTINES -- PREVIOUSLY ^LAB("X","...") ;1/26/07 18:36
2 ;;5.2;LAB SERVICE;**65,153,201,217,290,360,350**;Sep 27, 1994;Build 10
3PT ;patient info
4 ;
5 N X,I,N,Y
6 D KVAR^VADPT
7 K LRTREA,LRWRD,AGE S (AGE,PNM,SEX,DOB,DOD,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""
8 I $G(LRDFN),'$G(LRDPF),$G(^LR(LRDFN,0)) S LRDPF=$P(^(0),U,2),DFN=$P(^(0),U,3)
9 S LREND=0 S:$G(DFN)<1!('$G(LRDPF)) LREND=1 Q:$G(LREND)
10 I +$G(LRDPF)'=2 D
11 . S X=$$GET1^DID(1,+LRDPF,"","GLOBAL NAME","ANS","ANS1")
12 . S X=X_DFN_",0)",X=$S($D(@X):@X,1:""),LRWRD=$S($D(^(.1)):$P(^(.1),U),1:0),LRRB=$S($D(^(.101)):$P(^(.101),U),1:""),DOD=$S($D(^(.35)):$P(^(.35),U),1:"")
13 . S PNM=$P(X,U),SSN=$P(X,U,9) Q:+$G(LRDPF)=62.3
14 . S SEX=$P(X,U,2),SEX=$S(SEX="":"M",1:SEX)
15 . S DOB=$P(X,U,3)
16 . S AGE=$S($D(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")
17 . S AGE(2)=$$AGE2(DOB,$G(LRCDT)) ;Age of the patient when the specimen was collected (default =99Yr if no valid DOB present)
18 . ;Default for LRCDT (collection date) is DT
19 I +$G(LRDPF)=2 D
20 . N I,X,N,Y
21 . D OERR^VADPT D:'VAERR
22 . . S PNM=VADM(1)
23 . . S SEX=$P(VADM(5),U),DOB=$P(VADM(3),U),DOD=$P(VADM(6),U)
24 . . S AGE=VADM(4),AGE(2)=$$AGE2(DOB,$G(LRCDT))
25 . . ; S SSN=$P(VADM(2),U),LRWRD=$P(VAIN(4),U,2)
26 . . S SSN=VA("PID"),LRWRD=$P(VAIN(4),U,2) ; for VOE
27 . . S LRWRD(1)=+VAIN(4),LRRB=VAIN(5),LRPRAC=+VAIN(2)
28 . . S:VAIN(3) LRTREA=+VAIN(3)
29 D SSNFM^LRU
30 Q
31DEM ;Call DEM^VADPT instead of OERR used above
32 N X,I,N,Y
33 D KVAR^VADPT
34 K LRTREA,LRWRD,AGE S (AGE,PNM,SEX,DOB,SSN,VA200,LRWRD,LRRB,LRTREA,VA("PID"),VA("BID"))=""
35 I $G(LRDFN),'$G(LRDPF),$G(^LR(LRDFN,0)) S LRDPF=$P(^(0),U,2),DFN=$P(^(0),U,3)
36 S LREND=0 S:$G(DFN)<1!('$G(LRDPF)) LREND=1 Q:$G(LREND)
37 I +$G(LRDPF)'=2 D
38 . S X=^DIC(+LRDPF,0,"GL")_DFN_",0)",X=$S($D(@X):@X,1:""),LRWRD=$S($D(^(.1)):$P(^(.1),U),1:0),LRRB=$S($D(^(.101)):$P(^(.101),U),1:"")
39 . S PNM=$P(X,U),SEX=$P(X,U,2),SEX=$S(SEX="":"M",1:SEX),DOB=$P(X,U,3)
40 . S AGE=$S($D(DT)&(DOB?1(7N,7N1".".6N)):DT-DOB\10000,1:"??")
41 . S AGE(2)=$$AGE2(DOB,$G(LRCDT))
42 . S SSN=$P(X,U,9)
43 I +$G(LRDPF)=2 N I,X,N,Y D
44 . D DEM^VADPT D:'VAERR
45 . . S PNM=VADM(1),SEX=$P(VADM(5),U)
46 . . ; S DOB=$P(VADM(3),U),SSN=$P(VADM(2),U)
47 . . S DOB=$P(VADM(3),U),SSN=VA("PID") ; for VOE
48 . . S AGE=VADM(4),AGE(2)=$$AGE2(DOB,$G(LRCDT))
49 D SSNFM^LRU
50 Q
51DD ;date/time format
52 S Y=$$FMTE^XLFDT(Y,"5Z")
53 S Y=$P(Y,"@")_" "_$P($P(Y,"@",2),":",1,2)
54 Q
55DDOLD ;OLD
56 I $E(Y,4,7)="0000" S Y=$S($E(Y)=2:"19"_$E(Y,2,3),1:"20"_$E(Y,2,3)) Q
57 S Y=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
58 Q
59DT ;current date format is LRDT0
60 N X,DIK,DIC,%I,DICS,%DT
61 D DT^DICRW
62 S Y=$$FMTE^XLFDT(DT,"5D")
63 S LRDT0=Y
64 Q
65DTOLD ;2-DIGIT
66 ;current date format is LRDT0
67 N X,DIK,DIC,%I,DICS,%DT
68 D DT^DICRW
69 S Y=$P(DT,".") D DDOLD S LRDTO=Y
70 Q
71DASH ;line of dashes
72 W !,$E("--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------",1,IOM-1)
73 Q
74EQUALS ;line of equals
75 W !,$E("====================================================================================================================================================================================================================",1,IOM-1)
76 Q
77DUZ ;user info
78 S (LRUSNM,LRUSI)="" Q:'$D(X) Q:'$D(^VA(200,+X,0)) S LRUSNM=$P(^(0),"^"),LRUSI=$P(^(0),"^",2)
79 Q
80DOC ;provider info
81 I $L(X),'X S LRDOC=X Q
82 S LRDOC=$P($G(^VA(200,+X,0)),U)
83 S:LRDOC="" LRDOC="Unknown"
84 Q
85PRAC(X) ;prac info
86 N Y
87 I $L(X),'X Q X
88 S Y=$P($G(^VA(200,+X,0)),U)
89 S:Y="" Y="Unknown"
90 Q Y
91YMD ;year/month/date
92 S %=%H>21549+%H-.1,%Y=%\365.25+141,%=%#365.25\1,%D=%+306#(%Y#4=0+365)#153#61#31+1,%M=%-%D\29+1,X=%Y_"00"+%M_"00"+%D K %Y,%D,%M,%
93 Q
94STAMP ;time stamp
95 S X="N",%DT="ET" D ^%DT
96 Q
97KEYCOM ;key to result flags
98 D EQUALS W !!," ------------------------------ COMMENTS ------------------------------",!," Key: 'L' = reference Low, 'H' = reference Hi, '*' = critical range"
99 Q
100URG ;urgencys
101 K LRURG S LRURG(0)="ROUTINE" S I=0 F S I=$O(^LAB(62.05,I)) Q:I<1 I $D(^(I,0)) S:'$P(^(0),U,3) LRURG(I)=$P(^(0),U)
102 Q
103ADD ;date format
104 S Y=$E("JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC",$E(Y,4,5)*3-2,$E(Y,4,5)*3)_" "_$S(Y#100:$J(Y#100\1,2)_", ",1:"")_(Y\10000+1700)_$S(Y#1:" "_$E(Y_0,9,10)_":"_$E(Y_"000",11,12),1:"")
105 Q
106INF ;Display Infectious Warning
107 I $L($G(IO)),$D(^LR(LRDFN,.091)),$L(^(.091)),'$G(LRQUIET) W !,$C(7)," Pat Info: ",^(.091) Q
108 Q
109LRGLIN ;
110 N HZ
111 D GSET^%ZISS W IOG1
112 F HZ=1:1:79 W IOHL
113 W IOG0 D GKILL^%ZISS
114 W !
115 Q
116LRUID(LRAA,LRAD,LRAN) ;Extrinsic function call to create a unique
117 ;accession identifier for an accession number. See description
118 ;of field .092 in file 68 for a full explanation of this number.
119 ;This function returns a value equal to the unique ID generated.
120 ;LRAA=ien in file 68, accession area
121 ;LRAD=ien for accession date in field 68.01
122 ;LRAN=ien for accession number in field 68.02
123 Q:$S('$G(LRAA):1,'$D(^LRO(68,LRAA,.4)):1,1:0) 0
124 N DA,DIE,DLAYGO,DR,LRMNTH,LRUID,LRQTR,LRTYPE,LRYR1,LRYR2,LRJUL
125 S LRUID=$P($G(^LRO(68,LRAA,.4)),"^") ;start building LRUID
126 S:$L(LRUID)'=2 LRUID="0"_LRUID
127 S LRTYPE=$P($G(^LRO(68,LRAA,0)),"^",3)
128 S LRYR1=$E(LRAD,3)
129 S LRYR2=$E(LRAD,2,3)
130 S LRMNTH=$E(LRAD,4,5)
131 S LRQTR=0_(LRMNTH\3.1+1)
132 I "DW"[LRTYPE D
133 . S X1=LRAD,X2=$E(LRAD,1,3)_"0101" D ^%DTC
134 . S X=X+1,LRJUL=$E("000",1,3-$L(X))_X
135 . S LRUID=LRUID_LRYR1_LRJUL
136 . S LRUID=LRUID_$E("0000",1,4-$L(LRAN))_LRAN
137 I LRTYPE="Y" D
138 . S LRUID=LRUID_LRYR2_$E("000000",1,6-$L(LRAN))_LRAN
139 I LRTYPE="Q" D
140 . S LRUID=LRUID_LRYR1_LRQTR
141 . S LRUID=LRUID_$E("00000",1,5-$L(LRAN))_LRAN
142 I LRTYPE="M" D
143 . S LRUID=LRUID_LRYR1_LRMNTH_$E("00000",1,5-$L(LRAN))_LRAN
144 L +^LRO(68,"C"):99999
145 I $D(^LRO(68,"C",LRUID)),'$D(^LRO(68,"C",LRUID,LRAA,LRAD,LRAN)) D
146 . N X
147 . S X=$E(LRUID,3,10)
148 . F S LRUID="00"_X Q:'$D(^LRO(68,"C",LRUID)) S X=X+1 S:X>99999999 X=11111111
149 ;The following fields are also set in rtn LROLOVER
150SET3 I $G(LRORDRR)'="R" S DR="16////"_LRUID
151 I $G(LRORDRR)="R" D
152 . S DR=";16.1////"_+$G(LRRSITE("RSITE"))_";16.2////"_+$G(LRRSITE("RPSITE"))_";16.3////"_LRUID_";16.4////"_LRSD("RUID")
153 . I '$G(LRRSITE("IDTYPE")),'$D(^LRO(68,"C",LRSD("RUID"))) S LRUID=LRSD("RUID") ; Use sender's UID, unless previously used.
154 . S DR="16////"_LRUID_DR
155 S DA=LRAN,DA(1)=LRAD,DA(2)=LRAA,DIE="^LRO(68,"_DA(2)_",1,"_DA(1)_",1,",DLAYGO=68
156 D ^DIE
157 L -^LRO(68,"C")
158 S LRORU3=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
159 Q LRUID
160 ;
161KVAR ;Kill laboratory/VADPT patient demographics
162 K LRTREA,LRWRD,PNM,SEX,DOB,DOD,SSN,LRWRD,LRRB,LRTREA,VA,LRDFN,LRDPF,LREND,VAERR
163 D KVA^VADPT
164 Q
165ADDPT ;Returns VAPA( Patient data
166 N X,I,N,Y D ADD^VADPT Q
167OPDPT ;Returns VAPD( Patient data
168 N X,I,N,Y D OPD^VADPT Q
169SVCPT ;Returns VASV( Patient data
170 N X,I,N,Y D SVC^VADPT Q
171OADPT ;Returns VAOA( Patient data
172 N X,I,N,Y D OAD^VADPT Q
173INPPT ;Returns VAIN( Patient data
174 N X,I,N,Y D INP^VADPT Q
175IN5PT ;Returns VAIP( Patient data
176 N X,I,N,Y D IN5^VADPT Q
177PIDPT ;Returns VA("PID") and VA("BID") Patient Identifier
178 N X,I,N,Y D PID^VADPT Q
179 ;
180 ;
181 QUIT
182Y2K(X,LRYR) ; --> used to convert 2digit year to 4digit century and year
183 ; 1/1/91 TO 1/1/1991
184 ;
185 ;S X=$P(X,".") ;--> Date only. Not time
186 S LRYR=$G(LRYR,"5S")
187 N YR
188 S Y=$$FMTE^XLFDT(X,LRYR)
189 I $L($P(Y,"/"))=1 S $P(Y,"/")="0"_$P(Y,"/") ;--> pad for 2digit day
190 I $L($P(Y,"/",2))=1 S $P(Y,"/",2)="0"_$P(Y,"/",2) ;--> for 2digit month
191 Q Y
192 ;
193 QUIT
194RD ;DIR read
195 N Y,X
196 K LRANSY,LRANSX
197 S LREND=0 W !
198 D ^DIR I $D(DTOUT)!($D(DUOUT))!($D(DIRUT))!($D(DIROUT)) S LREND=1
199 S LRANSY=$G(Y),LRANSX=$G(X)
200 Q
201AGE2(DOB,LRCDT) ;Entry point if passing only a valid Date without patient
202 ; DOB, LRCDT must be defined in VA FileManager internal format
203 ; Date error will return 99yr
204 N X,Y,%DT
205 I '$G(LRCDT) S LRCDT=$$DT^XLFDT
206 I '$G(DOB) Q "99yr" ;no DOB passed
207 S DOB=$P(DOB,".")
208 S X=DOB,LRCDT=$P(LRCDT,".")
209 I $S(DOB'=+DOB:1,LRCDT'=+LRCDT:1,1:0) Q "99yr"
210 I $S(DOB'?7N.NE:1,LRCDT'?7N.NE:1,1:0) Q "99yr"
211 D ^%DT I Y'>0 Q "99yr" ;invalid date
212 S X=LRCDT
213 K %DT D ^%DT I Y'>0 Q "99yr" ;invalid date
214 ;
215CALC ;Calculate timeframe based on difference between DOB and collection
216 ; date. Time is stripped off.
217 ; .0001-24 hour = dy
218 ; 0-29 days = dy
219 ; 30-730 dy = mo
220 ; >24 mo = yr
221 ;
222 I DOB>LRCDT Q "99yr" ;DOB in future
223 I DOB=LRCDT Q "1dy" ;same dates---pass 1 day old
224 S X=$E(LRCDT,1,3)-$E(DOB,1,3)-($E(LRCDT,4,7)<$E(DOB,4,7))
225 I X>1 S X=+X_"yr" Q X ;age 2 years or more---pass in years
226 S X=$$FMDIFF^XLFDT(LRCDT,DOB,1)
227 I X>30 S X=X\30_"mo" Q X ;over 30 days---pass in months
228 E S X=X_"dy" Q X ;under 31 days---pass in days
229 Q "99yr"
Note: See TracBrowser for help on using the repository browser.