source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRODATA.m@ 1739

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

initial load of WorldVistAEHR
File size: 5.9 KB
RevLine 
[613]1IMRODATA ; HCIOFO-FAI/SPS - SPECIAL DATA EXTRACT; 03/29/02 13:35 ;
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**15**;Feb 09, 1998
3ENTRY ; Entry to run daily extract to gather past missing data.
4 I $$PATCH^XPDUTL("IMR*2.1*15")=1 W !,?23,"***PATCH 15 EXTRACT HAS ALREADY BEEN RUN***" D KIL Q
5 W !!,"This is a one-time run job to populate the National Database ",!,"with data starting from 1/1/84."
6 S ZTDTH=XPDQUES("POS1")
7 D ASK
8 Q
9EN1 ; Entry point from post-init. The following variables must be defined;
10 ; IMRED,IMRC,IMRSET,IMRDT
11 Q:'$D(^IMR(158.9,1,0)) ;quit if no site parameters
12 N IMRTRANS S U="^",IMRC=0,IMRSET=0 ;IMRC=message line counter, IMRSET=message counter
13 S (IMRED,IMRDT,IMRDTT)=$$NOW^XLFDT() ;IMRED & IMRDT=set data extract end date/time
14 S IMRTRANS=1,IMRSD="2840101" ; Tell the system that this is a transmit to national
15 D DOMAIN^IMRUTL ;get the domain name for ICR
16 S IMRDOMN="S.IMRHDATA@"_IMRDOMN ;append domain to server name
17 K ^TMP($J)
18 I '$D(IMRSTN) D IMROPN^IMRXOR Q:'$D(IMRSTN)
19 S X=10987654321 D XOR^IMRXOR S IMRCODE=X ;encrypt patient SSN
20 ;increment message line # & message sequence number below
21 ; set segment=START^station number^date of data collection^message sequence number^encryption code^IMR version number
22 S IMRC=IMRC+1,IMRSET=IMRSET+1
23 S ^TMP($J,"IMRX",IMRC)="START"_"^"_IMRSTN_"^"_IMRDT_"^"_IMRSET_"^"_IMRCODE_"^"_$$VERSION^XPDUTL("IMR")_"^15" D SEGS,LCHK
24 ; NEXT CASE node: piece #1=NEXT CASE, piece #2=LAST NEW CASE
25 S:'$D(^IMR(158.9,1,"NXT")) ^("NXT")=0 S IMRNXT2=+$P(^("NXT"),"^",2),IMRNXT1=+^("NXT")
26 ; Process new entries first, then process existing entries
27 S IMRFN=0
28 F S IMRFN=$O(^IMR(158,IMRFN)) Q:IMRFN'>0 S IMRSEND=0 D NXT
29 D SEND^IMRODAT1
30 D LCHK
31KIL K IMRDENT,IMRRAD,IMRRX,IMRLAB,IMRMI,IMRSCH,IMRCODE,IMRT1,IMRT2,DFN,IMRDFN,IMRFN,IMRED,IMRDT,IMR101,IMRNXT1,IMRNXT2,IMROP,IMRSET,IMRSTN,X,X1,X2,IMRC,IMRSSN,%DT,Y,%H,%,IMRTRANS
32 K ^TMP($J),%T,DIC,IMRN,IMRSCH1,J,XCNP,XMZ,VAERR,D,DISYS,POP,IMRPAD,IMRADM,IMRDIS,IMRDOMN,IMRSEND,IMR5,IMRDTT,IMRL,IMRT,IMRTEST,IMRTRAN,IMRTSTI,IMRSD,IMRAD,IMRM90
33 D POST^IMRPT15
34 Q
35HEADER ; set segment=START^station number^date of data collection^message sequence number^encryption code^IMR version number
36 S IMRC=IMRC+1,IMRSET=IMRSET+1,^TMP($J,"IMRX",IMRC)="START"_"^"_IMRSTN_"^"_IMRDT_"^"_IMRSET_"^"_IMRCODE_"^"_$$VERSION^XPDUTL("IMR")_"^15" D SEGS,LCHK
37 Q
38NXT D CLEAR
39 ; Node 101 contains last dates noted for various services provided
40 ; Node 5 is the date of death node
41 S IMR101=$G(^IMR(158,IMRFN,101)),IMRI=+IMR101,IMR5=$G(^IMR(158,IMRFN,5)),IMRTRAN=$P(IMR5,"^",21)
42 S IMRT1=$P($H,",",2) ;IMRT1 is used to calculate the number of seconds needed to extract data for patient
43 S X=+^IMR(158,IMRFN,0)
44 D XOR^IMRXOR Q:'$D(^DPT(X,0)) ;decode patient id, quit if not in File 2
45 S (DFN,IMRDFN)=X,IMRT2="" ;IMRT2 identify's record as new or update
46 I $P(IMR101,"^",2)="" S IMRT2="NEW" D DEMOG ;piece #2=LAST SCHEDULING DATE NOTED
47 I IMRT2="" S IMRT2="UPD" D DEMOG
48 I IMR101'="" S IMRT1=$P($H,",",2)-IMRT1 S:IMRT1<0 IMRT1=IMRT1+(24*60*60) S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="TIME"_"^"_IMRT2_"^"_IMRT1 D LCHK
49LCHK I (IMRC#5000)=0 D SEND^IMRODAT1 Q
50 Q
51DEMOG Q:'$D(^DPT(DFN,0))
52 D DEM^VADPT,ELIG^VADPT,SVC^VADPT,ADD^VADPT
53 Q:$G(VADM(2))="" S X=$P(VADM(2),"^") D XOR^IMRXOR S IMRSSN=X ;encrypt patient SSN
54 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="PA"_"^"_IMRSSN D LCHK
55 Q:$G(VADM(3))="" S X=$E($P(VADM(3),"^"),1,5)_"00" D XOR^IMRXOR S IMRDOB=X ;encrypt patient's date of birth
56 Q:$G(VADM(5))="" S IMRSEX=$P(VADM(5),"^"),IMRZIP=$G(VAPA(6)),IMRPOS=$P($G(VAEL(2)),"^",2) ;sex, zip code, and IMRPOS=period of service (external value)
57 S IMRELIG=$P($G(VAEL(1)),"^",2),IMRSEPD=$P($G(VASV(6,5)),"^") ;current primary eligibility & service separation date
58 S IMRDOD=$P($G(VADM(6)),"^")
59 I +IMRDOD>0 D
60 . S $P(^IMR(158,IMRFN,5),"^",19,20)=IMRDOD_"^"_1,$P(^IMR(158,IMRFN,1),U,34)=2 ;save MAS DOD as IMR Date of Death, flag DOD as from MAS
61 . I IMRDOD S $P(^IMR(158,IMRFN,5),"^",21)=1 ;is this data for deceased patient?
62 I IMRDOD'>0 D
63 . S:$P(^IMR(158,IMRFN,1),U,34)=2 $P(^(1),U,34)=1
64 . S $P(^IMR(158,IMRFN,5),U,19,20)=""_U_""
65 ; segment=DEmographic^date of birth (encrypted)^sex^zip code^period of service^eligibility code^service separation date^^date of death
66 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="DE"_"^"_IMRDOB_"^"_IMRSEX_"^"_IMRZIP_"^"_IMRPOS_"^"_IMRELIG_"^"_IMRSEPD_"^"_"^"_IMRDOD D LCHK
67 K IMRDOB,IMRSEX,IMRZIP,IMRPOS,IMRELIG,IMRSEPD,IMRDOD,VA,VADM,VAEL,VAPA,VASV S IMRFLG=0
68 D GETDAT^IMRODAT1
69 Q
70CLEAR ; Kill Variables
71 K IMRT1,IMRT2,DFN,IMRLD,IMRLD1,IMRLD2
72 Q
73ASK ; Entry Point to Process Data Extract For A Given Date Range
74 S IMRSD="2840101",(IMRDT,IMRED)=DT,IMRC=0,IMRSET=0
75DQ ; Queue Data Extract
76 D NOW^%DTC
77 I $G(ZTDTH)="" S ZTDTH=%H
78 S ZTRTN="EN1^IMRODATA"
79 S ZTSAVE("*")="",ZTIO="",ZTDESC="Patch 15 One-Time IMR Data Extract"
80 D ^%ZTLOAD
81 K ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTIO,ZTSK
82 Q
83SEGS ;
84 Q:$G(DFN)=""
85 Q:'$D(^DPT(DFN,0))
86 Q:'$D(^IMR(158,IMRFN,0))
87 D DEM^VADPT,ELIG^VADPT,SVC^VADPT,ADD^VADPT
88 S X=$P(VADM(2),"^") D XOR^IMRXOR S IMRSSN=X ;encrypt patient SSN
89 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="PA"_"^"_IMRSSN
90 S X=$E($P(VADM(3),"^"),1,5)_"00" D XOR^IMRXOR S IMRDOB=X ;encrypt patient's date of birth
91 S IMRSEX=$P(VADM(5),"^"),IMRZIP=VAPA(6),IMRPOS=$P(VAEL(2),"^",2) ;sex, zip code, and IMRPOS=period of service (external value)
92 S IMRELIG=$P(VAEL(1),"^",2),IMRSEPD=$P(VASV(6,5),"^") ;current primary eligibility & service separation date
93 S IMRDOD=$P(VADM(6),"^")
94 I +IMRDOD>0 D
95 . S $P(^IMR(158,IMRFN,5),"^",19,20)=IMRDOD_"^"_1,$P(^IMR(158,IMRFN,1),U,34)=2 ;save MAS DOD as IMR Date of Death, flag DOD as from MAS
96 . I IMRDOD S $P(^IMR(158,IMRFN,5),"^",21)=1 ;is this data for deceased patient?
97 I IMRDOD'>0 D
98 . Q:'$D(^IMR(158,IMRFN,0))
99 . S:$P(^IMR(158,IMRFN,1),U,34)=2 $P(^(1),U,34)=1
100 . S $P(^IMR(158,IMRFN,5),U,19,20)=""_U_""
101 ; segment=DEmographic^date of birth (encrypted)^sex^zip code^period of service^eligibility code^service separation date^^date of death
102 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="DE"_"^"_IMRDOB_"^"_IMRSEX_"^"_IMRZIP_"^"_IMRPOS_"^"_IMRELIG_"^"_IMRSEPD_"^"_"^"_IMRDOD
103 S IMRFLG=0
104 Q
Note: See TracBrowser for help on using the repository browser.