source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRX.m@ 1487

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

initial load of FOIAVistA 6/30/08 version

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