source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCXMA.m@ 1800

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

initial load of WorldVistAEHR

File size: 5.6 KB
RevLine 
[613]1HBHCXMA ; LR VAMC(IRMS)/MJT-HBHC populate ^HBHC(634) with Evaluation/Admission Data or ^HBHC(634.1), file of records in ^HBHC(631) containing missing/erroneous data, called by ^HBHCFILE, calls ^HBHCXMA1 ;9/02
2 ;;1.0;HOSPITAL BASED HOME CARE;**1,6,9,19**;NOV 01, 1993
3 D START^HBHCXMA1
4LOOP ; Loop thru ^HBHC(631) "AE","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.1) => Evaluation/Admission Error(s) file
5 S HBHCDFN="" F S HBHCDFN=$O(^HBHC(631,"AE","N",HBHCDFN)) Q:HBHCDFN="" S HBHCFLG=1 D SETNODE I HBHCFLG D:HBHCDR="" TRANS D:HBHCDR]"" ERROR^HBHCXMA1
6EXIT ; Exit module
7 D EXIT^HBHCXMA1
8 Q
9SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.1) Evaluation/Admission Error(s))
10 S HBHCINFO=^HBHC(631,HBHCDFN,0),HBHCXMT3=$P($G(^HBHC(631,HBHCDFN,1)),U,17)
11 ; Quit if admission date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
12 I $P(HBHCINFO,U,18)>HBHCLSDT S HBHCFLG=0 Q
13 S HBHCDPT0=^DPT(+HBHCINFO,0),HBHCDR=""
14 S DFN=+HBHCINFO K VADM D DEM^VADPT D RACE,ETH
15 S HBHCAFLG=0 F HBHCK=19:1:37 Q:HBHCAFLG S:$P(HBHCINFO,U,HBHCK)]"" HBHCAFLG=1
16 S HBHCRFLG=0 S:($P(HBHCINFO,U,16)]"")!($P(HBHCINFO,U,17)]"") HBHCRFLG=1
17 S HBHCADDT=$S($P(HBHCINFO,U,18)]"":$E($P(HBHCINFO,U,18),4,5)_$E($P(HBHCINFO,U,18),6,7)_(1700+$E($P(HBHCINFO,U,18),1,3)),1:HBHCSP8)
18 ; Use Evaluation Date for historical 'Reject' purposes
19 S:HBHCADDT=HBHCSP8 HBHCADDT=$S($P(HBHCINFO,U,2)]"":$E($P(HBHCINFO,U,2),4,5)_$E($P(HBHCINFO,U,2),6,7)_(1700+$E($P(HBHCINFO,U,2),1,3)),1:HBHCSP8)
20 S:HBHCADDT=HBHCSP8 HBHCDR=HBHCDR_"17;"
21 S HBHCST=$S($P(HBHCINFO,U,3)]"":$P(^DIC(5,(+^HBHC(631.8,($P(HBHCINFO,U,3)),0)),0),U,3),1:"") S:HBHCST="" HBHCDR=HBHCDR_"2;"
22 S HBHCCNTY="" S:(($P(HBHCINFO,U,3)]"")&($P(HBHCINFO,U,4)]"")) HBHCCNTY=$P($G(^DIC(5,(+^HBHC(631.8,($P(HBHCINFO,U,3)),0)),1,$P(HBHCINFO,U,4),0)),U,3) S:HBHCCNTY="" HBHCDR=HBHCDR_"3;"
23 S HBHCZIP=$S($P(HBHCINFO,U,5)]"":$P(HBHCINFO,U,5),1:"") S:$L(HBHCZIP)'=9 HBHCZIP=HBHCZIP_HBHCSP4 S:HBHCZIP="" HBHCDR=HBHCDR_"4;"
24 S HBHCELGE=$S($P(HBHCINFO,U,6)]"":$P(HBHCINFO,U,6),1:"") S:HBHCELGE="" HBHCDR=HBHCDR_"5;"
25 S HBHCBYR=$S($P(HBHCDPT0,U,3):1700+$E($P(HBHCDPT0,U,3),1,3),1:"0000")
26 S HBHCPSRV=$S($P(HBHCINFO,U,8)]"":$P(^HBHC(631.7,$P(HBHCINFO,U,8),0),U),1:"") S:HBHCPSRV="" HBHCDR=HBHCDR_"7;"
27 S HBHCSX=$P(HBHCDPT0,U,2),HBHCSEX=$S(HBHCSX="M":1,1:2)
28 ; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference; HBHCRC set to X in HBHCXMA1 mjt
29 ;S HBHCRC=$S($P(HBHCDPT0,U,6)]"":$P(^DIC(10,$P(HBHCDPT0,U,6),0),U,2),1:""),HBHCRACE=$S(HBHCRC=6:1,HBHCRC=4:2,(HBHCRC=1)!(HBHCRC=2):3,HBHCRC=3:4,HBHCRC=5:5,1:9)
30 F HBHCI=1:1:4 S HBHCFLD=$P(HBHCFLD1,U,HBHCI) S @HBHCFLD=$S($P(HBHCINFO,U,HBHCI+10)]"":$P(HBHCINFO,U,HBHCI+10),1:"") S:@HBHCFLD="" HBHCDR=HBHCDR_(HBHCI+9)_";"
31 S HBHCRFIN=$S($P($G(^HBHC(631,HBHCDFN,1)),U,29)]"":$P($G(^HBHC(631,HBHCDFN,1)),U,29),1:HBHCSP1)
32 S HBHCACTN=$S($P(HBHCINFO,U,15)]"":$P(HBHCINFO,U,15),1:"") I (HBHCACTN="")!((HBHCACTN=1)&(HBHCRFLG=1))!((HBHCACTN=2)&(HBHCAFLG=1)) S HBHCDR=HBHCDR_"14;" Q
33 S HBHCREJ=$S($P(HBHCINFO,U,16)]"":$P(^HBHC(631.1,$P(HBHCINFO,U,16),0),U),1:HBHCSP2) S:(HBHCACTN=2)&(HBHCREJ=HBHCSP2) HBHCDR=HBHCDR_"15;"
34 S HBHCREJD=$S($P(HBHCINFO,U,17)]"":$P(HBHCINFO,U,17),1:HBHCSP1) S:(HBHCACTN=2)&(HBHCREJD=HBHCSP1) HBHCDR=HBHCDR_"16;"
35 S HBHCICDA=$S($P(HBHCINFO,U,19)]"":$P($P(^ICD9($P(HBHCINFO,U,19),0),U),".")_$P($P(^ICD9($P(HBHCINFO,U,19),0),U),".",2),1:HBHCSP6) S:$L(HBHCICDA)<6 HBHCICDA=HBHCICDA_$J("",6-$L(HBHCICDA)) S:(HBHCACTN=1)&(HBHCICDA=HBHCSP6) HBHCDR=HBHCDR_"18;"
36 F HBHCJ=1:1:18 S HBHCFLD=$P(HBHCFLD2,U,HBHCJ) S @HBHCFLD=$S($P(HBHCINFO,U,HBHCJ+19)]"":$P(HBHCINFO,U,HBHCJ+19),1:HBHCSP1) S:(HBHCACTN=1)&(@HBHCFLD=HBHCSP1) HBHCDR=HBHCDR_(HBHCJ+18)_";"
37 Q:HBHCDR]""
38 S HBHCNAME=$P(^DPT($P(HBHCINFO,U),0),U) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
39 S HBHCSSN=$P(^DPT($P(HBHCINFO,U),0),U,9)
40 S HBHCREC=HBHCFORM_HBHCHOSP_HBHCSSN_HBHCADDT_HBHCST_HBHCCNTY_HBHCZIP_HBHCELGE_HBHCBYR_HBHCPSRV_HBHCSEX_HBHCRC_HBHCMARE_HBHCLIVE_HBHCCARE_HBHCTYPE_HBHCRFIN_HBHCACTN_HBHCREJ_HBHCREJD_HBHCNAME
41 S HBHCREC=HBHCREC_HBHCICDA_HBHCVISA_HBHCHERA_HBHCEXCA_HBHCRECA_HBHCBTHA_HBHCDRSA_HBHCTLTA_HBHCTRNA_HBHCEATA_HBHCWLKA_HBHCBWLA_HBHCBLDA_HBHCMOBA_HBHCADTA_HBHCBHVA_HBHCDSOA_HBHCMODA_HBHCLMTA_HBHCRACE_HBHCETH
42 Q
43RACE ; Race Jan 2003 mandate: 7 Race codes (w/corresponding Collection Method codes) exist, 4 additional 'slots' are for future expansion = 11 total for loop counter for data fill in transmit record
44 S HBHCRACE="",HBHCEND=11,HBHCNODE=12,HBHCFIL=1
45 D LOOP2
46 S HBHCRACE=HBHCVAR
47 Q
48ETH ; Ethnicity Jan 2003 mandate: 4 Ethnicity codes (w/corresponding Collection Method codes) exist, 4 additional 'slots' are for future expansion = 8 total for loop counter for data fill in transmit record
49 S HBHCETH="",HBHCEND=8,HBHCNODE=11,HBHCFIL=2
50 D LOOP2
51 S HBHCETH=HBHCVAR
52 Q
53LOOP2 ; Loop 2
54 S HBHCVAR=""
55 F HBHCL=1:1:HBHCEND S:'$D(VADM(HBHCNODE,HBHCL)) HBHCVAR=HBHCVAR_HBHCSP2 I $D(VADM(HBHCNODE,HBHCL)) D SET S HBHCVAR=HBHCVAR_HBHCPTFV_HBHCCM
56 Q
57SET ; Set PTF Value & Collection Method Variables
58 S HBHCIENP=$P(VADM(HBHCNODE,HBHCL),U)
59 S HBHCIEN2=$P(VADM(HBHCNODE,HBHCL,1),U)
60 S HBHCPTFV=$$PTR2CODE^DGUTL4(HBHCIENP,HBHCFIL,HBHCPTF)
61 S HBHCCM=$$PTR2CODE^DGUTL4(HBHCIEN2,HBHCT103,HBHCPTF)
62 Q
63TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(631)
64 L +^HBHC(634,0) S HBHCNDX1=$P(^HBHC(634,0),U,3)+1,$P(^HBHC(634,0),U,3)=HBHCNDX1,$P(^HBHC(634,0),U,4)=$P(^HBHC(634,0),U,4)+1 L -^HBHC(634,0)
65 S $P(^HBHC(634,HBHCNDX1,0),U)=HBHCREC,^HBHC(634,"B",$E(HBHCREC,1,30),HBHCNDX1)=""
66 L +^HBHC(631,HBHCDFN,1) K:HBHCXMT3]"" ^HBHC(631,"AE",HBHCXMT3,HBHCDFN) S $P(^HBHC(631,HBHCDFN,1),U,17)="F",^HBHC(631,"AE","F",HBHCDFN)="",$P(^HBHC(631,HBHCDFN,1),U,19)=HBHCTDY L -^HBHC(631,HBHCDFN,1)
67 Q
Note: See TracBrowser for help on using the repository browser.