source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRUTL.m@ 1096

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

initial load of WorldVistAEHR
File size: 6.5 KB
Line 
1IMRUTL ;HCIOFO/SPS - Immunology Data Gathering Utility Routine ; 10/7/02 11:24am
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**8,9,5,18,19**;Feb 09, 1998
3 ;
4 ; Referrence to EN^PSOORDER supported by DBIA #1878
5 ;
6RAD ; Get Radiology exam data. Output is in ^TMP($J,"RAE1"))
7 D EN1^RAO7PC1(IMRDFN,IMRSD,IMRED,999999)
8 Q
9RXARC(DFN) ; Input IMRDFN and Return the last Deletion Date of patient in Variable Y
10 N IMRARC,IMRRI S Y="" D GETS^DIQ(55,DFN,"101*","I","IMRARC") ;101*=archive date of pharmacy patient file
11 G:'$D(IMRARC) EXIT
12 S IMRRI="A" F S IMRRI=$O(IMRARC(55.13,IMRRI),-1) Q:IMRRI="" D
13 .S Y=$P(IMRRI,",",1) Q:'Y
14 .Q
15EXIT Q Y
16RX1589() ; Return the archive date stored in File 158.9
17 Q $P($G(^IMR(158.9,1,"A")),U,1)
18 ;
19RX ; Gathering the Outpatient Pharmacy Data
20 N BUF,I,L
21 D EN^PSOORDER(,IMRR)
22 ;
23 S BUF=$G(^TMP("PSOR",$J,IMRR,0))
24 S IMRRXD1=$P(BUF,U) ; issue date
25 S IMRFILDT=$P(BUF,U,2) ; fill date
26 S IMRRXD=$P(BUF,U,3) ; last dispensed date
27 S IMRDST=$$UP^XLFSTR($P($P(BUF,U,4),";",2)) ; status
28 S IMRQ=$P(BUF,U,6) ; qty
29 S IMRDSUP=$P(BUF,U,7) ; days supply
30 S IMREF=$P(BUF,U,8) ; # of refills
31 S IMRUCST=$P(BUF,U,10) ; unit price of drugs
32 S IMREXP=$P(BUF,U,12) ; expiration date
33 ;
34 S BUF=$G(^TMP("PSOR",$J,IMRR,1))
35 S IMRPS=$P($P(BUF,U,5),";",2) ; patient status
36 S IMRCL=+$P(BUF,U,4) ; clinic
37 S IMRCL=+$$ARSC^IMRUTL(+IMRCL) ; pointer to File 40.7
38 ; ; AMIS stop code
39 S IMRCL=$S(IMRCL:$P($G(^DIC(40.7,IMRCL,0)),U,2),1:"")
40 ;
41 S BUF=$G(^TMP("PSOR",$J,IMRR,"DRUG",0))
42 S IMRRXDR=$P($P(BUF,U),";",2) ; drug
43 S IMRXX1=+$P(BUF,U)
44 ; Price per dispensed unit
45 S IMRDU=$S(IMRXX1:$$GET1^DIQ(50,IMRXX1,16,"I"),1:0)
46 ;
47 S (I,IMRXSIG)="",L=245
48 F S I=$O(^TMP("PSOR",$J,IMRR,"SIG1",I)) Q:I="" D Q:L'>0
49 . S BUF=$G(^TMP("PSOR",$J,IMRR,"SIG1",I,0))
50 . S IMRXSIG=IMRXSIG_" "_$E(BUF,1,L)
51 . S L=L-$L(BUF)-1 S:L<-1 IMRXSIG=IMRXSIG_"..."
52 S IMRXSIG=$$TRIM^XLFSTR(IMRXSIG)
53 Q
54 ;
55RXF ; Get the Refill Information
56 K IMRAR D GETS^DIQ(52,IMRR,"52*","I","IMRAR") ;refill
57 Q
58PTF ; Get PTF Data
59 S IMRAD=$$GET1^DIQ(45,IMRPTF,2,"I") ;admission date
60 S IMRST=$$GET1^DIQ(45,IMRPTF,6,"I") ;status
61 S IMREC=$$GET1^DIQ(45,IMRPTF,11,"I") ;type of record
62 S IMRDD=$$GET1^DIQ(45,IMRPTF,70,"I") ;discharge date
63 S IMRDSP=$$GET1^DIQ(45,IMRPTF,71,"E") ;discharge specialty
64 S IMRDISP=$$GET1^DIQ(45,IMRPTF,72,"E") ;type of disposition
65 S IMROUT=$$GET1^DIQ(45,IMRPTF,73,"I") ;outpatient treatment
66 S IMRSUF=$$GET1^DIQ(45,IMRPTF,5,"I") ;suffix
67 S IMRFB=$$GET1^DIQ(45,IMRPTF,4,"I") ;fee basis
68 Q
69ICDP ; Get the ICD Codes
70 K IMRAR D GETS^DIQ(45,IMRPTF,"79;79.16;79.17;79.18;79.19;79.201;79.21;79.22;79.23;79.24","E","IMRAR") ;79=dxls, 79.16-79.24=icd2-icd10
71 Q
72ICDM ; Get the ICD Codes
73 K IMRAR D GETS^DIQ(45,IMRPTF,"50*","EI","IMRAR") ;501->movement record
74 Q
75SPROC ; Get Surgery/Procedure Operation Code
76 K IMRAR D GETS^DIQ(45,IMRPTF,"40*","EI","IMRAR") ;401->surgery/procedure
77 Q
78PROC ; Get Procedure Code
79 K IMRAR D GETS^DIQ(45,IMRPTF,"60*","EI","IMRAR") ;601->procedure date
80 Q
81CAT ; Check Category of Patient For a Specified Date Range
82 N XC0,Y1,Y2,Y3,Y4 S XC0=$G(^IMR(158,IMRRL,0)),Y1=$P(XC0,"^",36),Y3=$P(XC0,"^",35),Y4=$P(XC0,"^",23),Y2=$P(XC0,"^",44)
83 S IMR0C=$S(Y4>0&(Y4'>IMRED):4,Y3>0&(Y3'>IMRED):3,Y2>0&(Y2'>IMRED):2,Y1>0&(Y1'>IMRED):1,1:$S(+$G(IMR0C):+$G(IMR0C),1:0))
84 ; piece 36->date of hiv+ (cat 1) status
85 ; piece 35->date of aids (cat 3) status
86 ; piece 23->date of aids (cat 4)
87 ; piece 44->date of hiv+ (cat 2) status
88 Q
89LAB60 ; Retrieve the Laboratory Test Name
90 S IMRLAB60=$$GET1^DIQ(60,IMR60,.01,"E")
91 Q
92NLAB ; Retrieve the National Lab Name
93 S IMRNLAB=""
94 S IMRNLAB=$$GET1^DIQ(60,IMRLABT,64,"E")
95 Q
96LRARC ; Return the Date of Lab data Purge in variable IMRLRC
97 N IMRAR,IMRI D GETS^DIQ(69.9,1,"600*","I","IMRAR") ;archive data field of the laboratory site file
98 S IMRLRC="" Q:'$D(IMRAR)
99 S IMRI="" F S IMRI=$O(IMRAR(69.9003,IMRI)) Q:IMRI="" S IMRLRC=$G(IMRAR(69.9003,IMRI,4,"I")) ;4->for data before date
100 Q
101REORDER ; re-order IMRAR array for File 45, field #50 (501) to make data
102 ; in order of date
103 S IMRLOOP="" K IMR4502,IMRFIRST
104 F S IMRLOOP=$O(IMRAR(45.02,IMRLOOP)) Q:IMRLOOP="" D
105 .I +$P(IMRLOOP,",",1)=1 S IMRFIRST=IMRAR(45.02,IMRLOOP,2,"E")
106 .I +IMRAR(45.02,IMRLOOP,10,"I")>0 D
107 ..S IMRMOVE=+IMRAR(45.02,IMRLOOP,10,"I") Q:'IMRMOVE
108 ..S IMR4502(IMRMOVE)=IMRAR(45.02,IMRLOOP,2,"E")
109 ..Q
110 .Q
111 K IMRLOOP,IMRMOVE
112 Q
113DENT ; retrieve dental entry for a patient
114 ; Input=IMRRAI which is the .01 value (date/time) of File 221 entry
115 K IMRAR
116 Q:$G(IMRRAI)'>0
117 D GETS^DIQ(221,IMRRAI,"*","EI","IMRAR")
118 Q
119SDV ; get data from Scheduling Visits file (#409.5)
120 ; Input=IMRSDVI
121 K IMRAR
122 Q:$G(IMRSDVI)'>0
123 D GETS^DIQ(409.5,IMRSDVI,"*","EI","IMRAR")
124 Q
125SDVCS ; get Clinic Stop Codes (#10) from Scheduling Visits file (#409.5)
126 K IMRAR
127 K IMRAR D GETS^DIQ(409.5,IMRSDVI,"10*","EI","IMRAR")
128 Q
129PSOAC ; Store archive data from Pharmacy package
130 ; Called from the PSOARCCO routine
131 Q:$G(PSOAC)'>0 ;PSOAC must be defined
132 Q:PSOAC<$$RX1589^IMRUTL() ;quit if new archive date is before existing
133 N DA,DIE,DR
134 S DA=$O(^IMR(158.9,0)) Q:'DA
135 S DIE="^IMR(158.9,",DR="99///"_PSOAC
136 D ^DIE
137 Q
138DOMAIN ; Return Domain name for Immunology in variable IMRDOMN
139 S IMR1589=$O(^IMR(158.9,0)) I 'IMR1589 S IMRDOMN="" Q
140 S IMRDOMN=+$G(^IMR(158.9,1,"DOMAIN")) I 'IMRDOMN S IMRDOMN="" Q
141 S IMRDOMN=$$GET1^DIQ(4.2,IMRDOMN,.01,"I") ;domain name
142 K IMR1589
143 Q
144ARSC(IMRARSC) ; AMIS Reporting Stop Code
145 Q $$GET1^DIQ(44,IMRARSC,8,"I")
146 ;
147RESULT(IMRESULT) ; Massage lab result to return a number
148 S IMRESULT=$$UP^XLFSTR(IMRESULT)
149 S IMRESULT=$TR(IMRESULT,"ABCDEFGHIJKLMNOPQRSTUVWXYZ,<>!@#$%^&*-_+=':;/?\`~","")
150 S IMRESULT=+IMRESULT
151 Q IMRESULT
152 ;
153AGE(X1,X2) ; calculate number of years between two dates (e.g., age)
154 ; X1 is the first date (in FileMan format), for example, date of birth
155 ; X2 is the second date (in FileMan format), for example, DT
156 ; if X2 is undefined, then it is assumed to be DT
157 ; X1 is subtracted from X2
158 ; returns value in IMRAGE
159 N IMRAGE
160 S IMRAGE=""
161 S:'$D(X2) X2=DT
162 I X1'="" S IMRAGE=$E(X2,1,3)-$E(X1,1,3)-($E(X2,4,7)<$E(X1,4,7))
163 Q IMRAGE
164NTLAB1(X) ; Get pointer to NTLF from file 158.9
165 ; X = Local lab file entry
166 ; NTL = NTL IEN
167 N NTL
168 S NTL=""
169 I $D(^IMR(158.9,"ALR",X)) D
170 .N L1,L2,L3,LINE
171 .S (L1,L2,L3)=0
172 .S L1=$O(^IMR(158.9,"ALR",X,L1)) Q:L1<1
173 .S L2=$O(^IMR(158.9,"ALR",X,L1,L2)) Q:L2<1
174 .S L3=$O(^IMR(158.9,"ALR",X,L1,L2,L3)) Q:L3<1
175 .S NTL=+$G(^IMR(158.9,L1,3,L2,1,L3,0)) Q:NTL=""
176 .Q
177 Q NTL
Note: See TracBrowser for help on using the repository browser.