source: FOIAVistA/tag/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCXMA.m@ 628

HBHCXMA ; 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
 ;;1.0;HOSPITAL BASED HOME CARE;**1,6,9,19**;NOV 01, 1993
 D START^HBHCXMA1
LOOP ; Loop thru ^HBHC(631) "AE","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.1) => Evaluation/Admission Error(s) file
 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
EXIT ; Exit module
 D EXIT^HBHCXMA1
 Q
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.1) Evaluation/Admission Error(s))
 S HBHCINFO=^HBHC(631,HBHCDFN,0),HBHCXMT3=$P($G(^HBHC(631,HBHCDFN,1)),U,17)
 ; Quit if admission date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
 I $P(HBHCINFO,U,18)>HBHCLSDT S HBHCFLG=0 Q
 S HBHCDPT0=^DPT(+HBHCINFO,0),HBHCDR=""
 S DFN=+HBHCINFO K VADM D DEM^VADPT D RACE,ETH
 S HBHCAFLG=0 F HBHCK=19:1:37 Q:HBHCAFLG  S:$P(HBHCINFO,U,HBHCK)]"" HBHCAFLG=1
 S HBHCRFLG=0 S:($P(HBHCINFO,U,16)]"")!($P(HBHCINFO,U,17)]"") HBHCRFLG=1
 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)
 ; Use Evaluation Date for historical 'Reject' purposes 
 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)
 S:HBHCADDT=HBHCSP8 HBHCDR=HBHCDR_"17;"
 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;"
 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;"
 S HBHCZIP=$S($P(HBHCINFO,U,5)]"":$P(HBHCINFO,U,5),1:"") S:$L(HBHCZIP)'=9 HBHCZIP=HBHCZIP_HBHCSP4 S:HBHCZIP="" HBHCDR=HBHCDR_"4;"
 S HBHCELGE=$S($P(HBHCINFO,U,6)]"":$P(HBHCINFO,U,6),1:"") S:HBHCELGE="" HBHCDR=HBHCDR_"5;"
 S HBHCBYR=$S($P(HBHCDPT0,U,3):1700+$E($P(HBHCDPT0,U,3),1,3),1:"0000")
 S HBHCPSRV=$S($P(HBHCINFO,U,8)]"":$P(^HBHC(631.7,$P(HBHCINFO,U,8),0),U),1:"") S:HBHCPSRV="" HBHCDR=HBHCDR_"7;"
 S HBHCSX=$P(HBHCDPT0,U,2),HBHCSEX=$S(HBHCSX="M":1,1:2)
 ; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference; HBHCRC set to X in HBHCXMA1  mjt
 ;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)
 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)_";"
 S HBHCRFIN=$S($P($G(^HBHC(631,HBHCDFN,1)),U,29)]"":$P($G(^HBHC(631,HBHCDFN,1)),U,29),1:HBHCSP1)
 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
 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;"
 S HBHCREJD=$S($P(HBHCINFO,U,17)]"":$P(HBHCINFO,U,17),1:HBHCSP1) S:(HBHCACTN=2)&(HBHCREJD=HBHCSP1) HBHCDR=HBHCDR_"16;"
 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;"
 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)_";"
 Q:HBHCDR]""
 S HBHCNAME=$P(^DPT($P(HBHCINFO,U),0),U) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
 S HBHCSSN=$P(^DPT($P(HBHCINFO,U),0),U,9)
 S HBHCREC=HBHCFORM_HBHCHOSP_HBHCSSN_HBHCADDT_HBHCST_HBHCCNTY_HBHCZIP_HBHCELGE_HBHCBYR_HBHCPSRV_HBHCSEX_HBHCRC_HBHCMARE_HBHCLIVE_HBHCCARE_HBHCTYPE_HBHCRFIN_HBHCACTN_HBHCREJ_HBHCREJD_HBHCNAME
 S HBHCREC=HBHCREC_HBHCICDA_HBHCVISA_HBHCHERA_HBHCEXCA_HBHCRECA_HBHCBTHA_HBHCDRSA_HBHCTLTA_HBHCTRNA_HBHCEATA_HBHCWLKA_HBHCBWLA_HBHCBLDA_HBHCMOBA_HBHCADTA_HBHCBHVA_HBHCDSOA_HBHCMODA_HBHCLMTA_HBHCRACE_HBHCETH
 Q
RACE ; 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
 S HBHCRACE="",HBHCEND=11,HBHCNODE=12,HBHCFIL=1
 D LOOP2
 S HBHCRACE=HBHCVAR
 Q
ETH ; 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
 S HBHCETH="",HBHCEND=8,HBHCNODE=11,HBHCFIL=2
 D LOOP2
 S HBHCETH=HBHCVAR
 Q
LOOP2 ; Loop 2
 S HBHCVAR=""
 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
 Q
SET ; Set PTF Value & Collection Method Variables
 S HBHCIENP=$P(VADM(HBHCNODE,HBHCL),U)
 S HBHCIEN2=$P(VADM(HBHCNODE,HBHCL,1),U)
 S HBHCPTFV=$$PTR2CODE^DGUTL4(HBHCIENP,HBHCFIL,HBHCPTF)
 S HBHCCM=$$PTR2CODE^DGUTL4(HBHCIEN2,HBHCT103,HBHCPTF)
 Q
TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(631)
 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)
 S $P(^HBHC(634,HBHCNDX1,0),U)=HBHCREC,^HBHC(634,"B",$E(HBHCREC,1,30),HBHCNDX1)=""
 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)
 Q