source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCXMD.m@ 1006

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

initial load of WorldVistAEHR

File size: 4.5 KB
Line 
1HBHCXMD ; 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
2 ;;1.0;HOSPITAL BASED HOME CARE;**4,6,9,10,13,19**;NOV 01, 1993
3 D START^HBHCXMD1
4LOOP ; Loop thru ^HBHC(631) "AF","N" cross-ref to create nodes in ^HBHC(634) => transmit or ^HBHC(634.3) => Discharge Error(s) file
5 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
6EXIT ; Exit module
7 D EXIT^HBHCXMD1
8 Q
9SETNODE ; Set node in ^HBHC(634) (Transmit) or ^HBHC(634.3) (Discharge Error(s))
10 S HBHCNOD0=^HBHC(631,HBHCDFN,0),HBHCNOD1=$G(^HBHC(631,HBHCDFN,1)),HBHCXMT5=$P(HBHCNOD1,U,18)
11 ; Quit if discharge date is greater than HBHCLSDT (last date to include in transmit set up in ^HBHCFILE)
12 I $P(HBHCNOD0,U,40)>HBHCLSDT S HBHCFLG=0 Q
13 S (HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR4,HBHCDR5)=""
14 S HBHCTFLG=0 S:($P(HBHCNOD0,U,45)]"")!($P(HBHCNOD0,U,46)]"") HBHCTFLG=1
15 S HBHCDFLG=0 F HBHCL=47:1:55 Q:HBHCDFLG S:$P(HBHCNOD0,U,HBHCL)]"" HBHCDFLG=1
16 I HBHCNOD1]"" F HBHCM=1:1:10 Q:HBHCDFLG S:$P(HBHCNOD1,U,HBHCM)]"" HBHCDFLG=1
17 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:"")
18 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:"")
19 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
20 S:((HBHCDSDT="")&((HBHCDFLG=1)!(HBHCTFLG=1)!($D(HBHCDDTA)))) HBHCDR1="39;"_HBHCDR1
21 Q:HBHCSTAT=""
22 I HBHCSTAT=4 I (HBHCDFLG)!(HBHCTFLG) S HBHCDR1=HBHCDR1_"43;" Q
23 I (HBHC359[(U_HBHCSTAT_U))&(HBHCTFLG) S HBHCDR1=HBHCDR1_"43;" Q
24 I HBHCNOD1]"" I ($P(HBHCNOD1,U,15)]"")&(HBHCSTAT'=4) S HBHCDR1=HBHCDR1_"43;" Q
25 S HBHCDEST=$S($P(HBHCNOD0,U,45)]"":$P(HBHCNOD0,U,45),1:HBHCSP1) S:(HBHC12[(U_HBHCSTAT_U))&(HBHCDEST=HBHCSP1) HBHCDR1=HBHCDR1_"44;"
26 S HBHCAGCY=$S($P(HBHCNOD0,U,46)]"":$P(HBHCNOD0,U,46),1:HBHCSP1) S:(HBHC12[(U_HBHCSTAT_U))&(HBHCAGCY=HBHCSP1) HBHCDR1=HBHCDR1_"45;"
27 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
28 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
29 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
30 Q:(HBHCADDT="")!(HBHCDR1]"")!(HBHCDR2]"")!(HBHCDR3]"")!(HBHCDR4]"")!(HBHCDR5]"")
31 S HBHCCONT=1
32 S HBHCNAME=$E($P(^DPT($P(HBHCNOD0,U),0),U),1,5) S:$L(HBHCNAME)<HBHCLNTH HBHCNAME=HBHCNAME_$J("",HBHCLNTH-$L(HBHCNAME))
33 S HBHCSSN=$P(^DPT($P(HBHCNOD0,U),0),U,9)
34 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
35 S HBHCREC=HBHCREC_HBHCMOBD_HBHCADTD_HBHCBHVD_HBHCDSOD_HBHCMODD_HBHCLMTD_HBHCSP81
36 Q
37TRANS ; Set node in ^HBHC(634) transmit file & flag record as 'F" (filed for transmit) in ^HBHC(631)
38 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)
39 S $P(^HBHC(634,HBHCNDX1,0),U)=HBHCREC,^HBHC(634,"B",$E(HBHCREC,1,30),HBHCNDX1)=""
40 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)
41 Q
42ERROR ; Set node in ^HBHC(634.3) if data is incomplete or proper fields invalid for 'Discharge Status'
43 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)
44 S ^HBHC(634.3,HBHCNDX2,0)=$P(HBHCNOD0,U)_U_HBHCDFN
45 S:HBHCDR1]"" ^HBHC(634.3,HBHCNDX2,1)=HBHCDR1
46 S:HBHCDR2]"" ^HBHC(634.3,HBHCNDX2,2)=HBHCDR2
47 S:HBHCDR3]"" ^HBHC(634.3,HBHCNDX2,3)=HBHCDR3
48 S:HBHCDR4]"" ^HBHC(634.3,HBHCNDX2,4)=HBHCDR4
49 S:HBHCDR5]"" ^HBHC(634.3,HBHCNDX2,5)=HBHCDR5
50 S ^HBHC(634.3,"B",$P(HBHCNOD0,U),HBHCNDX2)=""
51 Q
Note: See TracBrowser for help on using the repository browser.