source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCXMD1.m@ 701

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

initial load of WorldVistAEHR

File size: 3.0 KB
Line 
1HBHCXMD1 ; LR VAMC(IRMS)/MJT-HBHC, called by ^HBHCXMD ;9203
2 ;;1.0;HOSPITAL BASED HOME CARE;**2,6,19**;NOV 01, 1993
3START ; Initialization
4 W !,"Processing Discharge/Form 5 Data"
5 S HBHCFORM=5,HBHC12="^1^2^",HBHC359="^3^5^9^",$P(HBHCSP1," ",2)="",$P(HBHCSP4," ",5)="",$P(HBHCSP6," ",7)="",$P(HBHCSP81," ",82)="",HBHCLNTH=5
6 S HBHCHOSP=$P($G(^DIC(4,$P(^HBHC(631.9,1,0),U,5),99)),U) S:$L(HBHCHOSP)'=7 HBHCHOSP=HBHCHOSP_$E(HBHCSP4,1,(7-($L(HBHCHOSP))))
7 S HBHCFLD1="HBHCELGD^HBHCMARD^HBHCLIVD^HBHCSTAT"
8 S HBHCFLD2="HBHCVISD^HBHCHERD^HBHCEXCD^HBHCRECD^HBHCBTHD^HBHCDRSD^HBHCTLTD^HBHCTRND"
9 S HBHCFLD3="HBHCEATD^HBHCWLKD^HBHCBWLD^HBHCBLDD^HBHCMOBD^HBHCADTD^HBHCBHVD^HBHCDSOD^HBHCMODD^HBHCLMTD"
10 K %DT S X="T" D ^%DT S HBHCTDY=Y
11 Q
12DFLT1 ; Process fields 5, 10, & 11 as default values for fields 40, 41 & 42
13 S HBHCX=$S(HBHCI=1:6,HBHCI=2:11,HBHCI=3:12,1:""),HBHCDFLT=""
14 S:$P(HBHCNOD0,U,HBHCX)]"" HBHCDFLT=$P($P(^DD(631,(HBHCX-1),0),($P(HBHCNOD0,U,HBHCX)_":"),2),";")
15 S HBHCDR1=$S(HBHCDFLT]"":HBHCDR1_(HBHCI+39)_"//"_HBHCDFLT_";",1:HBHCDR1_(HBHCI+39)_";")
16 Q
17ICDDFLT ; Process field 18 as default value for field 46
18 S HBHCDFLT=""
19 S:$P(HBHCNOD0,U,19)]"" HBHCDFLT=$P(^ICD9($P(HBHCNOD0,U,19),0),U)
20 S HBHCDR1=$S(HBHCDFLT]"":HBHCDR1_"46//"_HBHCDFLT_";",1:HBHCDR1_"46;")
21 Q
22DFLT2 ; Process fields 19 - 26 as default values for fields 47 - 54
23 S HBHCDFLT=""
24 S:(HBHCJ=3)&($P(HBHCNOD0,U,22)]"") HBHCDFLT=$P(^HBHC(631.2,$P(HBHCNOD0,U,22),0),U)
25 S:(HBHCJ=4)&($P(HBHCNOD0,U,23)]"") HBHCDFLT=$P(^HBHC(631.3,$P(HBHCNOD0,U,23),0),U)
26 S:(HBHCJ'=3)&(HBHCJ'=4)&($P(HBHCNOD0,U,HBHCJ+19)]"") HBHCDFLT=$P($P(^DD(631,(HBHCJ+18),0),($P(HBHCNOD0,U,HBHCJ+19)_":"),2),";")
27 S:(HBHCJ=1)!(HBHCJ=2) HBHCDR1=$S(HBHCDFLT]"":HBHCDR1_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR1_(HBHCJ+46)_";")
28 S:(HBHCJ=3)!(HBHCJ=4)!(HBHCJ=5) HBHCDR2=$S(HBHCDFLT]"":HBHCDR2_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR2_(HBHCJ+46)_";")
29 S:(HBHCJ=6)!(HBHCJ=7)!(HBHCJ=8) HBHCDR3=$S(HBHCDFLT]"":HBHCDR3_(HBHCJ+46)_"//"_HBHCDFLT_";",1:HBHCDR3_(HBHCJ+46)_";")
30 Q
31DFLT3 ; Process fields 27 - 36 as default values for fields 55 - 64
32 S HBHCDFLT=""
33 S:$P(HBHCNOD0,U,HBHCK+27)]"" HBHCDFLT=$P($P(^DD(631,(HBHCK+26),0),($P(HBHCNOD0,U,HBHCK+27)_":"),2),";")
34 S:HBHCK=1 HBHCDR3=$S(HBHCDFLT]"":HBHCDR3_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR3_(HBHCK+54)_";")
35 S:(HBHCK>1)&(HBHCK<6) HBHCDR4=$S(HBHCDFLT]"":HBHCDR4_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR4_(HBHCK+54)_";")
36 S:HBHCK>5 HBHCDR5=$S(HBHCDFLT]"":HBHCDR5_(HBHCK+54)_"//"_HBHCDFLT_";",1:HBHCDR5_(HBHCK+54)_";")
37 Q
38EXIT ; Exit module
39 K HBHC12,HBHC359,HBHCADDT,HBHCADTD,HBHCAGCY,HBHCBHVD,HBHCBLDD,HBHCBTHD,HBHCBWLD,HBHCCONT,HBHCDATE,HBHCDDTA,HBHCDEST,HBHCDFLG,HBHCDFLT,HBHCDFN,HBHCDR1,HBHCDR2,HBHCDR3,HBHCDR3,HBHCDR4,HBHCDR5,HBHCDRSD,HBHCDSDT,HBHCDSOD,HBHCEATD
40 K HBHCELGD,HBHCEXCD,HBHCFLD,HBHCFLD1,HBHCFLD2,HBHCFLD3,HBHCFLG,HBHCFORM,HBHCHERD,HBHCHOSP,HBHCI,HBHCICDD,HBHCJ,HBHCK,HBHCL,HBHCLIVD,HBHCLMTD,HBHCLNTH,HBHCM,HBHCMARD,HBHCMOBD,HBHCMODD,HBHCNAME,HBHCNDX1,HBHCNDX2,HBHCNOD0
41 K HBHCNOD1,HBHCREC,HBHCRECD,HBHCSP1,HBHCSP4,HBHCSP6,HBHCSP81,HBHCSSN,HBHCSTAT,HBHCTDY,HBHCTFLG,HBHCTLTD,HBHCTRND,HBHCVISD,HBHCWLKD,HBHCX,HBHCXMT5,X,Y,%DT
42 Q
Note: See TracBrowser for help on using the repository browser.