| 1 | HBHCXMA1 ; LR VAMC(IRMS)/MJT-HBHC, called by ^HBHCXMA, entry points: START, ERROR, EXIT ; Jul 2000
|
|---|
| 2 | ;;1.0;HOSPITAL BASED HOME CARE;**2,6,14,19**;NOV 01, 1993
|
|---|
| 3 | START ; Initialization
|
|---|
| 4 | W !,"Processing Admission/Form 3 Data"
|
|---|
| 5 | S HBHCFORM=3,$P(HBHCSP1," ",2)="",$P(HBHCSP2," ",3)="",$P(HBHCSP4," ",5)="",$P(HBHCSP6," ",7)="",$P(HBHCSP8," ",9)="",HBHCLNTH=30
|
|---|
| 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="HBHCMARE^HBHCLIVE^HBHCCARE^HBHCTYPE"
|
|---|
| 8 | S HBHCFLD2="HBHCVISA^HBHCHERA^HBHCEXCA^HBHCRECA^HBHCBTHA^HBHCDRSA^HBHCTLTA^HBHCTRNA^HBHCEATA^HBHCWLKA^HBHCBWLA^HBHCBLDA^HBHCMOBA^HBHCADTA^HBHCBHVA^HBHCDSOA^HBHCMODA^HBHCLMTA"
|
|---|
| 9 | K %DT S X="T" D ^%DT S HBHCTDY=Y
|
|---|
| 10 | ; Initialize variables passed for $$PRT2CODE^DGUTL4(VALUE,TYPE,CODE) calls
|
|---|
| 11 | ; Following comments stolen from DGUTL4 routine:
|
|---|
| 12 | ; Convert pointer to specified code
|
|---|
| 13 | ; Input: VALUE - Pointer to RACE file (#10), ETHNICITY file (#10.2),
|
|---|
| 14 | ; or RACE AND ETHNICITY COLLECTION METHOD file (#10.3)
|
|---|
| 15 | ; TYPE - Flag indicating which file VALUE is for
|
|---|
| 16 | ; 1 = Race (default)
|
|---|
| 17 | ; 2 = Ethnicity
|
|---|
| 18 | ; 3 = Collection Method
|
|---|
| 19 | ; CODE - Flag indicating which code to return
|
|---|
| 20 | ; 1 = Abbreviation (default)
|
|---|
| 21 | ; 2 = HL7
|
|---|
| 22 | ; 3 = CDC (not applicable for Collection Method)
|
|---|
| 23 | ; 4 = PTF
|
|---|
| 24 | ; End of DGUTL4 comment theft mjt
|
|---|
| 25 | ; Race = 10, Ethnicity = 102, Collection Method = 103
|
|---|
| 26 | ; Type
|
|---|
| 27 | S HBHCT103=3
|
|---|
| 28 | ; Code, PTF Value used for all files
|
|---|
| 29 | S HBHCPTF=4
|
|---|
| 30 | ; Race field set to "X" & became Historical only, beginning w/Jan 2003 new Race & Ethnicity Information fields mandate mjt
|
|---|
| 31 | S HBHCRC="X"
|
|---|
| 32 | Q
|
|---|
| 33 | ERROR ; Set node in ^HBHC(634.1) if data is incomplete or proper fields invalid for 'Admit/Reject Action'
|
|---|
| 34 | L +^HBHC(634.1,0) S HBHCNDX2=$P(^HBHC(634.1,0),U,3)+1,$P(^HBHC(634.1,0),U,3)=HBHCNDX2,$P(^HBHC(634.1,0),U,4)=$P(^HBHC(634.1,0),U,4)+1 L -^HBHC(634.1,0)
|
|---|
| 35 | S ^HBHC(634.1,HBHCNDX2,0)=$P(HBHCINFO,U)_U_HBHCDFN,^HBHC(634.1,HBHCNDX2,1)=HBHCDR,^HBHC(634.1,"B",$P(HBHCINFO,U),HBHCNDX2)=""
|
|---|
| 36 | Q
|
|---|
| 37 | EXIT ; Exit module => cleanup for HBHCXMA
|
|---|
| 38 | K HBHCACTN,HBHCADDT,HBHCADTA,HBHCAFLG,HBHCBHVA,HBHCBLDA,HBHCBTHA,HBHCBWLA,HBHCBYR,HBHCCM,HBHCCARE,HBHCCNTY,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCDR,HBHCDRSA,HBHCDSOA,HBHCEATA,HBHCELGE,HBHCEND,HBHCETH,HBHCEXCA,HBHCFIL,HBHCFLD,HBHCFLD1
|
|---|
| 39 | K HBHCFLD2,HBHCFLG,HBHCFORM,HBHCHERA,HBHCHOSP,HBHCI,HBHCICDA,HBHCIEN2,HBHCIENP,HBHCINFO,HBHCJ,HBHCK,HBHCL,HBHCLIVE,HBHCLMTA,HBHCLNTH,HBHCMARE,HBHCMOBA,HBHCMODA,HBHCNAME,HBHCNDX1,HBHCNDX2,HBHCNODE,HBHCPSRV,HBHCPTF,HBHCPTFV
|
|---|
| 40 | K HBHCRACE,HBHCRC,HBHCREC,HBHCRECA,HBHCREJ,HBHCREJD,HBHCRFIN,HBHCRFLG,HBHCSEX,HBHCSP1,HBHCSP2,HBHCSP4,HBHCSP6,HBHCSP8,HBHCSSN,HBHCST,HBHCSX,HBHCT103,HBHCTDY,HBHCTLTA,HBHCTRNA,HBHCTYPE,HBHCVAR,HBHCVISA,HBHCWLKA,HBHCXMT3,HBHCZIP
|
|---|
| 41 | K X,Y,%DT
|
|---|
| 42 | Q
|
|---|
