source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRPTF.m@ 1147

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1IMRPTF ; ISC-SF/JLI,HCIOFO/NCA,FT-EXTRACT PTF DATA FOR IMR REGISTRY DATABASE ; 7/5/02 1:54pm
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**14,18**;Feb 09, 1998
3 ; Called from IMRDAT
4 S (IMRADM,IMRDIS,IMRPAD,IMRPTX)=0
5 ; check PTF file (#45) - IMREC=TYPE OF RECORD (1:PTF,2:CENSUS)
6 S IMRPTF=0
7 F S IMRPTF=$O(^DGPT("B",IMRDFN,IMRPTF)) Q:IMRPTF'>0 D
8 . D PTF^IMRUTL Q:IMREC=2
9 . I IMRDD Q:IMRDD<IMRM90
10 . S:'IMRPTX IMRPTX=IMRAD D PTF
11 K IMRBS,IMRDD,IMRM1,IMRM2,IMRMN,IMRPTF,IMRPTX,IMRFLG,IMRI,IMRN,IMRST,IMRDSP,IMRDISP,IMROUT,IMRX,IMRX1,IMRAR,IMREC,X,IMR3
12 Q
13PTF ; Process Data Extract for PTF
14 Q:'IMRAD ;quit if no admission date
15 I IMRDD,IMRDD<IMRAD Q ;quit if discharge date before admission date
16 Q:IMRAD>IMRED ;quit if admission date after end date
17 ;--- Double check admission date. If not valid, set IMRFLG=1;
18 ;--- pass back discharge date if it exists
19 I 'IMRDD S IMRFLG=0 D Q:IMRFLG
20 . D DBCHK^IMRLCNT(IMRDFN,IMRAD,.IMRDD,.IMRFLG)
21 ;--- Send the admission IP segment once and wait for discharge
22 I 'IMRDD Q:IMRAD<IMRSD
23 ;--- InPatient episode
24 S IMRX="IP"_"^"_$S(IMRAD>0:IMRAD\1,1:"")_"^"
25 I IMRAD>IMRADM S IMRADM=IMRAD I IMRDD'>0 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)=IMRX S IMRSEND=1 K IMRX Q
26 Q:IMRDD'>0
27 S:IMRDD>IMRDIS IMRDIS=IMRDD
28 S IMRX=IMRX_(IMRDD\1)_"^"_IMRDSP_"^"_IMRDISP_"^"_IMROUT_"^" ;IMRDD=discharge date, IMRDSP=discharge specialty, IMRDISP=type of disposition, IMROUT=outpatient treatment
29 D ICDP^IMRUTL S (IMRI,IMRX1)="" ;get ICD codes (in IMRAR array)
30 G:'$D(IMRAR(45)) PTF1
31 ; concatenate ICD codes
32 S IMRI=$O(IMRAR(45,IMRI))
33 I IMRI'="" F IMRN=0:0 S IMRN=$O(IMRAR(45,IMRI,IMRN)) Q:IMRN<1 S X=$G(IMRAR(45,IMRI,IMRN,"E")) S IMRX1=IMRX1_X_"^"
34 S:IMRX1'="" IMRX1=$E(IMRX1,1,$L(IMRX1)-1) ;omit last up-arrow
35PTF1 S IMRX=IMRX_IMRX1
36 S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)=IMRX S IMRSEND=1 K IMRX
37 ; IMRST=status, IMRPTX=admission date
38 I IMRST>1&(IMRPTX=IMRAD) D PTFM S:IMRAD>IMRPAD IMRPAD=IMRAD S IMRPTX=0
39 Q
40PTFM ; IPM segment
41 D ICDM^IMRUTL G:'$D(IMRAR(45.02)) PTFS ;get movement data
42 D REORDER^IMRUTL
43 S IMRM2=IMRAD\1,IMR3=0
44 F S IMR3=$O(IMR4502(IMR3)) Q:'IMR3 S IMRI="" F S IMRI=$O(IMRAR(45.02,IMRI)) Q:IMRI="" I $G(IMRAR(45.02,IMRI,10,"I"))=IMR3 D
45 .S (IMRX,IMRX1)="",IMRM1=IMRM2
46 .S IMRBS=$G(IMRAR(45.02,IMRI,2,"E")) ;losing specialty
47 .F IMRN=5:1:9,11:1:15 S X=$G(IMRAR(45.02,IMRI,IMRN,"E")) S IMRX1=IMRX1_X_"^" ;concatenate ICD codes
48 .S:IMRX1'="" IMRX1=$E(IMRX1,1,$L(IMRX1)-1) ;omit last up-arrow
49 .S IMRM2=$G(IMRAR(45.02,IMRI,10,"I")) ;movement date
50 .S IMRX=IMRX_"^"_IMRX1
51 .S IMRBS=$S(IMRBS="":$$TREAT^IMRLCNT(IMRDFN),1:IMRBS) ;treatment specialty (external value)
52 .S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="IPM"_"^"_(IMRM1\1)_"^"_(IMRM2\1)_"^"_IMRBS_IMRX_"^"_(IMRAD\1) S IMRSEND=1 K IMRX,IMRX1 ;IMRAD=admission date,IMRM1=begin movement,IMRM2=end movement,IMRBS=losing specialty
53 .Q
54PTFS ; Obtain Surgery/Procedure Operation Codes (#401)
55 D SPROC^IMRUTL G:'$D(IMRAR(45.01)) PTFP S IMRI=""
56 F S IMRI=$O(IMRAR(45.01,IMRI)) Q:IMRI="" D
57 .S (IMRX,IMRX1)=""
58 .S IMRX=($G(IMRAR(45.01,IMRI,.01,"I"))\1) ;surgery/procedure date
59 .F IMRN=8:1:12 S X=$G(IMRAR(45.01,IMRI,IMRN,"E")) S IMRX1=IMRX1_X_"^" ;concatenate operation codes 1-5
60 .Q:IMRX1=""
61 .S:IMRX1'="" IMRX1=$E(IMRX1,1,$L(IMRX1)-1) ;omit last up-arrow
62 .S IMRX=IMRX_"^"_IMRX1
63 .S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="IPS"_"^"_(IMRAD\1)_"^"_IMRX K IMRX,IMRX1 S IMRSEND=1 ;IMRAD=admission date
64 .Q
65PTFP ; Obtain Procedure Codes (#601)
66 D PROC^IMRUTL Q:'$D(IMRAR(45.05)) S IMRI=""
67 F S IMRI=$O(IMRAR(45.05,IMRI)) Q:IMRI="" D
68 .S (IMRX,IMRX1)=""
69 .S IMRX=($G(IMRAR(45.05,IMRI,.01,"I"))\1) ;procedure date
70 .S IMRX=IMRX_"^"_$G(IMRAR(45.05,IMRI,1,"E"))
71 .F IMRN=4:1:8 S X=$G(IMRAR(45.05,IMRI,IMRN,"E")) S IMRX1=IMRX1_X_"^" ;concatenate procedure codes 1-5
72 .Q:IMRX1=""
73 .S:IMRX1'="" IMRX1=$E(IMRX1,1,$L(IMRX1)-1) ;omit last up-arrow
74 .S IMRX=IMRX_"^"_IMRX1
75 .S IMRC=IMRC+1,^TMP($J,"IMRX",IMRC)="IPP"_"^"_(IMRAD\1)_"^"_IMRX S IMRSEND=1 ;IMRAD=admission date
76 .K IMRX,IMRX1
77 .Q
78 Q
Note: See TracBrowser for help on using the repository browser.