source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRDAT1.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: 5.6 KB
Line 
1IMRDAT1 ;HCIOFO-NCA,FT/FAI-DATA EXTRACTION (cont.) ; 01/14/02 14:23 ; 12/24/02 9:30am
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**1,9,5,14,13,16,15,18,19**;Feb 09, 1998
3 ;
4 Q
5 ;
6 ;***** GETS ALL ANCILLARY PACKAGE DATA
7GETDAT ;
8 ;--- Get Outpatient Pharmacy Data
9RX D
10 . S IMRLD=+$P(IMR101,"^",6) ; LAST OPT PHARMACY DATE NOTED
11 . ;--- Perform the backpull if the start date is defined
12 . I $G(IMRSDBP(5.3))'>0 D
13 . . D:$D(IMRDTRX)>1 GET^IMRRX(IMRDTRX("S"),IMRDTRX("E"))
14 . . D GET^IMRRX(IMRSD,IMRED)
15 . E D GET^IMRRX(IMRSDBP(5.3),IMRED)
16 . ;--- Check FILL DATE against LAST OPT PHARMACY DATE NOTED
17 . S IMRLD=$S(IMRRX>IMRLD:IMRRX,1:IMRLD)
18 . S:IMRLD'>0 IMRLD=""
19 . ; piece 6=LAST OPT PHARMACY DATE NOTED
20 . ; piece 7=LAST INPT PHARMACY DATE NOTED
21 . ; piece 8=LAST IV PHARMACY DATE NOTED,
22 . ; piece 12=LAST LIMITED Rx dATE
23 . S $P(IMR101,"^",6,8)=IMRLD_"^^",$P(IMR101,"^",12)=IMRLD
24 . K IMRLD
25 ;
26 ;--- Get Lab Data
27LAB D
28 . S IMRLD=+$P(IMR101,"^",9) ; LAST LABORATORY DATE NOTED
29 . S IMRLD1=+$P(IMR101,"^",10) ; LAST MICROBIOLOGY DATE NOTED
30 . ; Perform the backpull if the start date is defined
31 . I $G(IMRSDBP(5.1))>0 N IMRSD S IMRSD=$G(IMRSDBP(5.1))
32 . D CHK^IMRLAB,^IMRBKLAB:'$G(IMRSDBP(5.1))
33 . S IMRLD=$S(IMRLAB>IMRLD:IMRLAB,1:IMRLD)
34 . S IMRLD1=$S(IMRMI>IMRLD1:IMRMI,1:IMRLD1)
35 . S:IMRLD'>0 IMRLD="" S:IMRLD1'>0 IMRLD1=""
36 . S $P(IMR101,"^",9,10)=IMRLD_"^"_IMRLD1
37 . ; piece 13=last limited lab date, piece 17=last limited micro date
38 . S $P(IMR101,"^",13)=IMRLD,$P(IMR101,"^",17)=IMRLD1
39 . K IMRLD,IMRLD1
40 ;
41 ;--- Get Radiology Data
42RAD ;
43 S IMRLD=+$P(IMR101,"^",11) D ^IMRRAD S:'IMRLD IMRLD="" ;LAST RADIOLOGY DATE NOTED
44 S $P(IMR101,"^",11)=$S(IMRRAD>IMRLD:IMRRAD,1:IMRLD) K IMRLD ;check latest EXAM DATE against last radiology date noted
45 ;
46 ;--- Get Dental Data
47DENT ;
48 S IMRLD=+$P(IMR101,"^",15) D DENT^IMRRAD S:'IMRLD IMRLD="" ;last dental appt date
49 S $P(IMR101,"^",15)=$S(IMRDENT>IMRLD:IMRDENT,1:IMRLD) K IMRLD
50 ;
51 ;--- Get Outpatient Activity Data
52OP ;
53 S IMRLD=+$P(IMR101,"^",16) D OP^IMRSCH S:'IMRLD IMRLD="" ;last OP date
54 S $P(IMR101,"^",16)=$S(IMROP>IMRLD:IMROP,1:IMRLD) K IMRLD ;check latest scheduling date/time against last OP date
55 ;
56WRAP S:IMRT2="NEW"!(IMRNXT2<IMRFN) IMRNXT2=IMRFN ;IMRNXT2=last new case
57 S ^IMR(158,IMRFN,101)=IMRDT_"^"_$P(IMR101,"^",2,99) ;IMRDT=LAST DATE DATA SURVEYED
58 Q
59 ;
60 ;***** SENDS A MESSAGE TO THE NATIONAL REGISTRY
61SEND(NEWPAT) ;
62 N IMRGI,TMP,XMDUZ,XMSUB,XMTEXT,XMY
63 ;--- Address message to coordinator if MAIL LIST flag is set to YES
64 S IMRGI=0
65 F S IMRGI=$O(^IMR(158.9,1,1,IMRGI)) Q:IMRGI'>0 D
66 . S TMP=^IMR(158.9,1,1,IMRGI,0)
67 . S:$P(TMP,U,2)=1 XMY(+TMP)=""
68 ;--- Send the message
69 S XMTEXT="^TMP($J,""IMRX"","
70 S TMP=$E(IMRDTT,4,5)_"-"_$E(IMRDTT,6,7)_"-"_$E(IMRDTT,2,3)
71 S XMSUB="IMMUNOLOGY DATA. "_IMRSTN_" "_TMP_" ("_IMRSET_")"
72 S:$G(NEWPAT) XMSUB=XMSUB_" *NEW PATIENT*"
73 S XMDUZ=.5,XMY(IMRDOMN)=""
74 D ^XMD
75 ;--- Create continuation message
76 K ^TMP($J) S IMRFLAG=1
77 D STARTSEG(),SEGS(1)
78 Q
79 ;
80MOVCDC0 ; Send nodes File 158 nodes if CDC form was generated.
81 Q:'IMRSEND
82 D CDC0()
83 F IMRI=1,2,102,108:1:112 I $G(^IMR(158,IMRFN,IMRI))'="" S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="CDC"_IMRI_"^"_^IMR(158,IMRFN,IMRI) D
84 .D LCHK^IMRDAT
85 .I IMRI=1 D
86 ..S IMRNODE1=$G(^TMP($J,"IMRX",IMRC))
87 ..S IMRSTATE=$P(IMRNODE1,U,13) ;state at onset of illness/aids
88 ..I IMRSTATE'="" S IMRSTATE=$$GET1^DIQ(5,IMRSTATE,1,"E") ;state abbr
89 ..S $P(IMRNODE1,U,13)=IMRSTATE
90 ..S IMRSTATE=$P(IMRNODE1,U,18) ;state of hospital - aids dx
91 ..I IMRSTATE'="" S IMRSTATE=$$GET1^DIQ(5,IMRSTATE,1,"E") ;state abbr
92 ..S $P(IMRNODE1,U,18)=IMRSTATE
93 ..S IMRSTATN=$P(IMRNODE1,U,8)
94 ..I IMRSTATN'="" S IMRSTATN=$$GET1^DIQ(4,IMRSTATN,99,"I") ;station #
95 ..S $P(IMRNODE1,U,8)=IMRSTATN
96 ..S $P(IMRNODE1,U,2)="*1*"
97 ..S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)=IMRNODE1
98 ..K IMRNODE1,IMRSTATE
99 ..Q
100 .Q
101 Q
102 ;
103 ;***** GENERATES THE CDC0 SEGMENT
104CDC0() ;
105 Q:$G(^IMR(158,IMRFN,0))=""
106 S IMRC=IMRC+1
107 S ^TMP($J,"IMRX",IMRC)="CDC0"_U_^IMR(158,IMRFN,0)
108 D LCHK^IMRDAT
109 Q
110 ;
111 ;***** PA & DE SEGMENTS
112SEGS(FPA,FDE,SIZECHK,VADM) ;
113 Q:$G(DFN)="" Q:'$D(^DPT(DFN,0))
114 Q:'$D(^IMR(158,IMRFN,0))
115 N IMRDOB,IMRDOD,IMRELIG,IMRPOS,IMRSEPD,IMRSEX,IMRZIP,VA,VAEL,VAPA,VASV
116 D DEM^VADPT,ELIG^VADPT,SVC^VADPT,ADD^VADPT
117 ;--- Encrypt the patient SSN
118 S X=$P(VADM(2),U) D XOR^IMRXOR S IMRSSN=X
119 ;--- PA^Coded SSN
120 I $G(FPA) D D:$G(SIZECHK) LCHK^IMRDAT
121 . S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="PA"_"^"_IMRSSN
122 ;--- Encrypt patient's date of birth
123 S X=$E($P(VADM(3),U),1,5)_"00" D XOR^IMRXOR S IMRDOB=X ;
124 ;--- Sex, ZIP code, and period of service (external value)
125 S IMRSEX=$P(VADM(5),U),IMRZIP=VAPA(6),IMRPOS=$P(VAEL(2),U,2)
126 ;--- Current primary eligibility & service separation date
127 S IMRELIG=$P(VAEL(1),U,2),IMRSEPD=$P(VASV(6,5),U)
128 ;--- Date of Death
129 S IMRDOD=$P(VADM(6),U)
130 I IMRDOD>0 D
131 . ;--- Save MAS DOD as IMR Date of Death, flag DOD as from MAS
132 . S $P(^IMR(158,IMRFN,5),U,19,20)=IMRDOD_U_1
133 . S $P(^IMR(158,IMRFN,1),U,34)=2
134 . ;--- Do not send the data after 60 days since DOD
135 . S:DT>$$FMADD^XLFDT(IMRDOD,60) $P(^IMR(158,IMRFN,5),U,21)=1
136 E D
137 . S:$P(^IMR(158,IMRFN,1),U,34)=2 $P(^(1),U,34)=1
138 . S $P(^IMR(158,IMRFN,5),U,19,20)=U
139 ;--- DE^date of birth (encrypted)^sex^zip code^period of service
140 ;--- ^eligibility code^service separation date^^date of death
141 I $G(FDE) D D:$G(SIZECHK) LCHK^IMRDAT
142 . S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="DE"_"^"_IMRDOB_"^"_IMRSEX_"^"_IMRZIP_"^"_IMRPOS_"^"_IMRELIG_"^"_IMRSEPD_"^^"_IMRDOD_"^"_DFN
143 S IMRFLG=0
144 Q
145 ;
146 ;***** START SEGMENT
147STARTSEG() ;
148 K ^TMP($J,"IMRX")
149 ;--- START^station number^date of data collection^message sequence
150 ;--- number^encryption code^IMR version number
151 S IMRC=IMRC+1,IMRSET=IMRSET+1
152 S ^TMP($J,"IMRX",IMRC)="START"_"^"_IMRSTN_"^"_IMRDT_"^"_IMRSET_"^"_IMRCODE_"^"_$$VERSION^XPDUTL("IMR")_"^19"
153 Q
Note: See TracBrowser for help on using the repository browser.