source: FOIAVistA/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCXMD.m@ 738

HBHCXMD ; LR VAMC(IRMS)/MJT-HBHC populate ^HBHC(634) with Discharge Data or ^HBHC(634.3), file of records in ^HBHC(631) containing missing/erroneous data, called by ^HBHCFILE, calls ^HBHCXMD1 ;9804
 ;;1.0;HOSPITAL BASED HOME CARE;**4,6,9,10,13,19**;NOV 01, 1993
 D START^HBHCXMD1
LOOP ; Loop thru ^HBHC(631) "AF","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.3) => Discharge Error(s) file
 S HBHCDFN="" F  S HBHCDFN=$O(^HBHC(631,"AF","N",HBHCDFN)) Q:HBHCDFN=""  S HBHCFLG=1,HBHCCONT=0 D SETNODE I HBHCFLG D:HBHCCONT TRANS D:'HBHCCONT ERROR
EXIT ; Exit module
 D EXIT^HBHCXMD1
 Q
SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.3) (Discharge Error(s))
 S HBHCNOD0=^HBHC(631,HBHCDFN,0),HBHCNOD1=$G(^HBHC(631,HBHCDFN,1)),HBHCXMT5=$P(HBHCNOD1,U,18)
 ; Quit if discharge date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
 I $P(HBHCNOD0,U,40)>HBHCLSDT S HBHCFLG=0 Q
 S (HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR4,HBHCDR5)=""
 S HBHCTFLG=0 S:($P(HBHCNOD0,U,45)]"")!($P(HBHCNOD0,U,46)]"") HBHCTFLG=1
 S HBHCDFLG=0 F HBHCL=47:1:55 Q:HBHCDFLG  S:$P(HBHCNOD0,U,HBHCL)]"" HBHCDFLG=1
 I HBHCNOD1]"" F HBHCM=1:1:10 Q:HBHCDFLG  S:$P(HBHCNOD1,U,HBHCM)]"" HBHCDFLG=1
 S HBHCADDT=$S($P(HBHCNOD0,U,18)]"":$E($P(HBHCNOD0,U,18),4,5)_$E($P(HBHCNOD0,U,18),6,7)_(1700+$E($P(HBHCNOD0,U,18),1,3)),$P(HBHCNOD0,U,2)]"":$E($P(HBHCNOD0,U,2),4,5)_$E($P(HBHCNOD0,U,2),6,7)_(1700+$E($P(HBHCNOD0,U,2),1,3)),1:"")
 S HBHCDSDT=$S($P(HBHCNOD0,U,40)]"":$E($P(HBHCNOD0,U,40),4,5)_$E($P(HBHCNOD0,U,40),6,7)_(1700+$E($P(HBHCNOD0,U,40),1,3)),1:"")
 K HBHCDDTA F HBHCI=1:1:4 S HBHCFLD=$P(HBHCFLD1,U,HBHCI) S:HBHCFLD]"" HBHCDDTA=1 S @HBHCFLD=$S($P(HBHCNOD0,U,HBHCI+40)]"":$P(HBHCNOD0,U,HBHCI+40),1:"") D:@HBHCFLD="" DFLT1^HBHCXMD1
 S:((HBHCDSDT="")&((HBHCDFLG=1)!(HBHCTFLG=1)!($D(HBHCDDTA)))) HBHCDR1="39;"_HBHCDR1
 Q:HBHCSTAT=""
 I HBHCSTAT=4 I (HBHCDFLG)!(HBHCTFLG) S HBHCDR1=HBHCDR1_"43;" Q
 I (HBHC359[(U_HBHCSTAT_U))&(HBHCTFLG) S HBHCDR1=HBHCDR1_"43;" Q
 I HBHCNOD1]"" I ($P(HBHCNOD1,U,15)]"")&(HBHCSTAT'=4) S HBHCDR1=HBHCDR1_"43;" Q
 S HBHCDEST=$S($P(HBHCNOD0,U,45)]"":$P(HBHCNOD0,U,45),1:HBHCSP1) S:(HBHC12[(U_HBHCSTAT_U))&(HBHCDEST=HBHCSP1) HBHCDR1=HBHCDR1_"44;"
 S HBHCAGCY=$S($P(HBHCNOD0,U,46)]"":$P(HBHCNOD0,U,46),1:HBHCSP1) S:(HBHC12[(U_HBHCSTAT_U))&(HBHCAGCY=HBHCSP1) HBHCDR1=HBHCDR1_"45;"
 S HBHCICDD=$S($P(HBHCNOD0,U,47)]"":$P($P(^ICD9($P(HBHCNOD0,U,47),0),U),".")_$P($P(^ICD9($P(HBHCNOD0,U,47),0),U),".",2),1:HBHCSP6) S:$L(HBHCICDD)<6 HBHCICDD=HBHCICDD_$J("",6-$L(HBHCICDD)) D:(HBHCSTAT'=4)&(HBHCICDD=HBHCSP6) ICDDFLT^HBHCXMD1
 F HBHCJ=1:1:8 S HBHCFLD=$P(HBHCFLD2,U,HBHCJ) S @HBHCFLD=$S($P(HBHCNOD0,U,HBHCJ+47)]"":$P(HBHCNOD0,U,HBHCJ+47),1:HBHCSP1) D:(HBHCSTAT'=4)&(@HBHCFLD=HBHCSP1) DFLT2^HBHCXMD1
 F HBHCK=1:1:10 S HBHCFLD=$P(HBHCFLD3,U,HBHCK) S @HBHCFLD=$S($P(HBHCNOD1,U,HBHCK)]"":$P(HBHCNOD1,U,HBHCK),1:HBHCSP1) D:(HBHCSTAT'=4)&(@HBHCFLD=HBHCSP1) DFLT3^HBHCXMD1
 Q:(HBHCADDT="")!(HBHCDR1]"")!(HBHCDR2]"")!(HBHCDR3]"")!(HBHCDR4]"")!(HBHCDR5]"")
 S HBHCCONT=1
 S HBHCNAME=$E($P(^DPT($P(HBHCNOD0,U),0),U),1,5) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
 S HBHCSSN=$P(^DPT($P(HBHCNOD0,U),0),U,9)
 S HBHCREC=HBHCFORM_HBHCHOSP_HBHCSSN_HBHCDSDT_HBHCELGD_HBHCMARD_HBHCLIVD_HBHCSTAT_HBHCDEST_HBHCAGCY_HBHCADDT_HBHCNAME_HBHCICDD_HBHCVISD_HBHCHERD_HBHCEXCD_HBHCRECD_HBHCBTHD_HBHCDRSD_HBHCTLTD_HBHCTRND_HBHCEATD_HBHCWLKD_HBHCBWLD_HBHCBLDD
 S HBHCREC=HBHCREC_HBHCMOBD_HBHCADTD_HBHCBHVD_HBHCDSOD_HBHCMODD_HBHCLMTD_HBHCSP81
 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:HBHCXMT5]"" ^HBHC(631,"AF",HBHCXMT5,HBHCDFN) S $P(^HBHC(631,HBHCDFN,1),U,18)="F",^HBHC(631,"AF","F",HBHCDFN)="",$P(^HBHC(631,HBHCDFN,1),U,22)=HBHCTDY L -^HBHC(631,HBHCDFN,1)
 Q
ERROR ; Set node in ^HBHC(634.3) if data is incomplete or proper fields invalid for 'Discharge Status'
 L +^HBHC(634.3,0) S HBHCNDX2=$P(^HBHC(634.3,0),U,3)+1,$P(^HBHC(634.3,0),U,3)=HBHCNDX2,$P(^HBHC(634.3,0),U,4)=$P(^HBHC(634.3,0),U,4)+1 L -^HBHC(634.3,0)
 S ^HBHC(634.3,HBHCNDX2,0)=$P(HBHCNOD0,U)_U_HBHCDFN
 S:HBHCDR1]"" ^HBHC(634.3,HBHCNDX2,1)=HBHCDR1
 S:HBHCDR2]"" ^HBHC(634.3,HBHCNDX2,2)=HBHCDR2
 S:HBHCDR3]"" ^HBHC(634.3,HBHCNDX2,3)=HBHCDR3
 S:HBHCDR4]"" ^HBHC(634.3,HBHCNDX2,4)=HBHCDR4
 S:HBHCDR5]"" ^HBHC(634.3,HBHCNDX2,5)=HBHCDR5
 S ^HBHC(634.3,"B",$P(HBHCNOD0,U),HBHCNDX2)=""
 Q