HBHCADM ;LR VAMC(IRMS)/MJT - HBHC eval/admit data entry; Apr 29, 2021@07:55
;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16,24,25,32,35**;NOV 01, 1993;Build 1
;
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to ^DG(40.8 supported by ICR #7024
;
;This routine appears to have locking flaws in that there is no allowance for
;locking failure. Any flaws will be researched and addressed in a future patch.
;HBH*1.0*32 is following the pattern of how HBHCADM currently locks records.
;
START ; Initialization
;Sites must have at least one parent site defined.
I $O(^HBHC(631.9,1,1,"B",""))="" D Q
. W !!,"No parent sites are defined at this facility."
. W !,"Contact your HBPC Program Manager to define at least one"
. W !,"parent site in option ""System Parameters Edit"".",!
. N DIR
. S DIR("A")="Press any key to continue",DIR(0)="FO"
. D ^DIR
S HBHCFORM=3
;Variable HBHCMFHS is set if this site is a
;sanctioned Medical Foster Home site.
D MFHS^HBHCUTL3
PROMPT ; Prompt user for patient name
N HBHCHOSP
S HBHCHOSP=$P(^HBHC(631.9,1,0),U,5)
K DIC,HBHCFLG,HBHCPRCT S DIC="^HBHC(631,",DIC(0)="AELMQZ" D ^DIC
G:Y=-1 EXIT
S HBHCDFN=+Y,HBHCDPT=$P(Y,U,2),HBHCDPT0=^DPT(HBHCDPT,0),HBHCNOD0=Y(0)
I $P(HBHCDPT0,U,9)'?9N W !!,"Patient has 'pseudo' social security number (SSN) on file. If patient was",!,"not chosen in error, contact MAS to correct the invalid SSN. Patient must",!,"have a valid SSN to be selected.",! H 3 G PROMPT
S HBHCXMT3=$P($G(^HBHC(631,HBHCDFN,1)),U,17)
I $P(^HBHC(631,HBHCDFN,0),U,40)]"" W $C(7),!!!,"*** Record contains Discharge data indicating a Complete Episode of Care ***",!! H 3
I (HBHCXMT3]"")&(HBHCXMT3'="N") D FORMMSG^HBHCUTL1 G:$D(HBHCNHSP) EXIT G:HBHCPRCT'=1 PROMPT
I $P(Y,U,3) S $P(^HBHC(631,HBHCDFN,1),U,17)="N",^HBHC(631,"AE","N",HBHCDFN)="" S HBHCBXRF="" F S HBHCBXRF=$O(^HBHC(631,"B",HBHCDPT,HBHCBXRF)) Q:(HBHCBXRF="")!(HBHCBXRF=HBHCDFN) D CHECK
G:$D(HBHCFLG) PROMPT
;
MFH ;HBH*1.0*32: first determine if an MFH patient
;Variable HBHCFMHS = does this site have Medical Foster Homes
I $D(HBHCMFHS) D
. N DIE,DA,DR,HBHCSAVY,HBHCMFHSTR,HBHCMFHX
. ;preserving "Y" since will be killed downstream
. M HBHCSAVY=Y
. S DIE="^HBHC(631,",DA=HBHCDFN
. S DR(2,631.01)=1,DR="K HBHCQ;88;S:X'=""Y"" Y=""@1"";89;90;@1;"
. L +^HBHC(631,HBHCDFN):0 I $T D ^DIE
. M Y=HBHCSAVY
;
MFHNO ;Either the site does not have medical foster homes,
;or this patient is not in a medical foster home.
;In that case, the Parent Site prompt is presented.
I $P($G(^HBHC(631,HBHCDFN,3)),"^")'="Y" D
. ;This section called only if patient is not an MFH patient.
. ;HBH*1.0*32: add PARENT SITE (#91) field
. ;set a default if there is only one parent site defined
. ;at this site
. N HBHCPARN,HBHCSAVY
. ;saving original value of Y since used further down by pre-HBH*1.0*32 code
. M HBHCSAVY=Y
. S HBHCPARN=$S($P(^HBHC(631.9,1,1,0),"^",4)=1:$O(^HBHC(631.9,1,1,"B","")),1:"")
. I HBHCPARN]"" S HBHCPARN=$P(^DG(40.8,HBHCPARN,0),"^")
. S DR="91//^S X=HBHCPARN"
. S DIE="^HBHC(631,",DA=HBHCDFN
. L +^HBHC(631,HBHCDFN):0 I $T D ^DIE L -^HBHC(631,HBHCDFN)
. M Y=HBHCSAVY
. ;end of HBH*1.0*32
CONT ;end of MFH logic - continue with prompts, etc.
;Parent site is required if not a MFH patient.
;Parent site is not required for MFH patients since the MFH's parent site
;is retrieved for AITC transmissions.
N HBHCQUIT
S HBHCQUIT=1
;Is parent site defined - if yes, may continue with prompts.
I $P($G(^HBHC(631,HBHCDFN,5)),"^")]"" S HBHCQUIT=0
;If no parent site and this is an MFH site, the patient needs to be defined
;as an MFH patient if there is no parent site in ^HBHC(631,HBHCDFN,5).
I HBHCQUIT,$D(HBHCMFHS),$P($G(^HBHC(631,HBHCDFN,3)),"^")="Y" S HBHCQUIT=0
Q:HBHCQUIT
D DEMO
K DIE S DIE="^HBHC(631,",DA=HBHCDFN,DIE("NO^")="OUTOK"
;added M code for Dx validation based on admission date
;added M code for Dx lookup instead of field 18
S DR="K HBHCQ;17;2:5;D BIRTHYR^HBHCUTL1;7;D SEXRACE^HBHCUTL1;10:13;14;D ACTION^HBHCUTL;15;16"
L +^HBHC(631,HBHCDFN):0 I $T D ^DIE
I $D(Y)>0 G PROMPT
; For ICD-9 lookups, set key variables used by special lookup routine
S ICDVDT=$P(^HBHC(631,DA,0),U,18)
S ICDSYS=+$$SINFO^ICDEX("DIAG",ICDVDT)
I ICDSYS=1 S ICDFMT=1
I '$D(HBHCMFHS) D
.S DR=$S(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
I $D(HBHCMFHS) D
.S DR=$S(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
D ^DIE
L -^HBHC(631,HBHCDFN) K ICDVDT,ICDSYS,ICDFMT G PROMPT
W $C(7),!!,"Another user is editing this entry.",!! G PROMPT
EXIT ; Exit module
K DA,DIC,DIE,DIK,DR,HBHCAFLG,HBHCBXRF,HBHCCNTY,HBHCDFN,HBHCDPT,HBHCDPT0,HBHCEL,HBHCELGE,HBHCFLG,HBHCFORM,HBHCI,HBHCIEN,HBHCINFO,HBHCJ,HBHCMARE,HBHCMFHS,HBHCMS,HBHCNHSP,HBHCNOD0,HBHCPRCT,HBHCPS,HBHCPSRV,HBHCQ,HBHCRFLG,HBHCST
K HBHCXMT3,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,HBHCZIP,VAEL,X,Y
Q
CHECK ; Check previous episode(s) of care for 'Reject' in Admit/Reject Action or Discharge Date to ensure completed episode of care before allowing another episode of care to be created
Q:($P(^HBHC(631,HBHCBXRF,0),U,15)=2)!($P(^HBHC(631,HBHCBXRF,0),U,40)]"")
W $C(7),!!,"Patient must be discharged from last episode of care before new episode",!,"can be entered. Current episode not created.",! H 3
K DIK S DIK="^HBHC(631,",DA=HBHCDFN D ^DIK
S HBHCFLG=1
Q
DEMO ; Obtain patient demographic info
S (HBHCST,HBHCCNTY,HBHCZIP,HBHCEL,HBHCELGE,HBHCPS,HBHCPSRV,HBHCMS,HBHCMARE)=""
I $D(^DPT(HBHCDPT,.11)) S HBHCINFO=^DPT(HBHCDPT,.11),HBHCCNTY=$P(HBHCINFO,U,7),HBHCZIP=$P(HBHCINFO,U,12),HBHCST=$P(HBHCINFO,U,5)
S HBHCIEN="" S:HBHCST HBHCIEN=$O(^HBHC(631.8,"B",HBHCST,HBHCIEN)) S HBHCST=$S($G(HBHCIEN):HBHCIEN,1:"") ;p35
I $D(^DPT(HBHCDPT,.36)) S DFN=HBHCDPT D ELIG^VADPT S HBHCEL=+VAEL(1),HBHCELGE=$S(HBHCEL=1:"01",HBHCEL=2:"02",HBHCEL=16:"02",HBHCEL=11:"03",HBHCEL=4:"04",1:"05") K DFN
I $D(^DPT(HBHCDPT,.32)) S HBHCINFO=^DPT(HBHCDPT,.32),HBHCPS=$P(HBHCINFO,U,3),HBHCPSRV=$S(((HBHCPS>0)&(HBHCPS<9)):HBHCPS,HBHCPS=9:10,HBHCPS=121:11,1:"")
S HBHCINFO=^DPT(HBHCDPT,0),HBHCMS=$P(HBHCINFO,U,5),HBHCMARE=$S(HBHCMS=1:4,HBHCMS=2:1,HBHCMS=4:2,HBHCMS=5:3,HBHCMS=6:5,1:"")
I HBHCST]"" S:($P(HBHCNOD0,U,3)="")&($D(^HBHC(631.8,HBHCST,0))) $P(^HBHC(631,HBHCDFN,0),U,3)=HBHCST I (HBHCCNTY]"")&($P(HBHCNOD0,U,4)="") S:$D(^HBHC(631.8,HBHCST,0)) $P(^HBHC(631,HBHCDFN,0),U,4)=HBHCCNTY
S:(HBHCZIP]"")&(($P(HBHCNOD0,U,5)="")!($P(HBHCNOD0,U,5)'?9N)) $P(^HBHC(631,HBHCDFN,0),U,5)=HBHCZIP
S:(HBHCELGE]"")&($P(HBHCNOD0,U,6)="") $P(^HBHC(631,HBHCDFN,0),U,6)=HBHCELGE
S:(HBHCPSRV]"")&($P(HBHCNOD0,U,8)="") $P(^HBHC(631,HBHCDFN,0),U,8)=HBHCPSRV
S:(HBHCMARE]"")&($P(HBHCNOD0,U,11)="") $P(^HBHC(631,HBHCDFN,0),U,11)=HBHCMARE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCADM 6906 printed Sep 23, 2025@19:33:59 Page 2
HBHCADM ;LR VAMC(IRMS)/MJT - HBHC eval/admit data entry; Apr 29, 2021@07:55
+1 ;;1.0;HOSPITAL BASED HOME CARE;**2,6,8,16,24,25,32,35**;NOV 01, 1993;Build 1
+2 ;
+3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
+4 ; Reference to ^DG(40.8 supported by ICR #7024
+5 ;
+6 ;This routine appears to have locking flaws in that there is no allowance for
+7 ;locking failure. Any flaws will be researched and addressed in a future patch.
+8 ;HBH*1.0*32 is following the pattern of how HBHCADM currently locks records.
+9 ;
START ; Initialization
+1 ;Sites must have at least one parent site defined.
+2 IF $ORDER(^HBHC(631.9,1,1,"B",""))=""
Begin DoDot:1
+3 WRITE !!,"No parent sites are defined at this facility."
+4 WRITE !,"Contact your HBPC Program Manager to define at least one"
+5 WRITE !,"parent site in option ""System Parameters Edit"".",!
+6 NEW DIR
+7 SET DIR("A")="Press any key to continue"
SET DIR(0)="FO"
+8 DO ^DIR
End DoDot:1
QUIT
+9 SET HBHCFORM=3
+10 ;Variable HBHCMFHS is set if this site is a
+11 ;sanctioned Medical Foster Home site.
+12 DO MFHS^HBHCUTL3
PROMPT ; Prompt user for patient name
+1 NEW HBHCHOSP
+2 SET HBHCHOSP=$PIECE(^HBHC(631.9,1,0),U,5)
+3 KILL DIC,HBHCFLG,HBHCPRCT
SET DIC="^HBHC(631,"
SET DIC(0)="AELMQZ"
DO ^DIC
+4 if Y=-1
GOTO EXIT
+5 SET HBHCDFN=+Y
SET HBHCDPT=$PIECE(Y,U,2)
SET HBHCDPT0=^DPT(HBHCDPT,0)
SET HBHCNOD0=Y(0)
+6 IF $PIECE(HBHCDPT0,U,9)'?9N
WRITE !!,"Patient has 'pseudo' social security number (SSN) on file. If patient was",!,"not chosen in error, contact MAS to correct the invalid SSN. Patient must",!,"have a valid SSN to be selected.",!
HANG 3
GOTO PROMPT
+7 SET HBHCXMT3=$PIECE($GET(^HBHC(631,HBHCDFN,1)),U,17)
+8 IF $PIECE(^HBHC(631,HBHCDFN,0),U,40)]""
WRITE $CHAR(7),!!!,"*** Record contains Discharge data indicating a Complete Episode of Care ***",!!
HANG 3
+9 IF (HBHCXMT3]"")&(HBHCXMT3'="N")
DO FORMMSG^HBHCUTL1
if $DATA(HBHCNHSP)
GOTO EXIT
if HBHCPRCT'=1
GOTO PROMPT
+10 IF $PIECE(Y,U,3)
SET $PIECE(^HBHC(631,HBHCDFN,1),U,17)="N"
SET ^HBHC(631,"AE","N",HBHCDFN)=""
SET HBHCBXRF=""
FOR
SET HBHCBXRF=$ORDER(^HBHC(631,"B",HBHCDPT,HBHCBXRF))
if (HBHCBXRF="")!(HBHCBXRF=HBHCDFN)
QUIT
DO CHECK
+11 if $DATA(HBHCFLG)
GOTO PROMPT
+12 ;
MFH ;HBH*1.0*32: first determine if an MFH patient
+1 ;Variable HBHCFMHS = does this site have Medical Foster Homes
+2 IF $DATA(HBHCMFHS)
Begin DoDot:1
+3 NEW DIE,DA,DR,HBHCSAVY,HBHCMFHSTR,HBHCMFHX
+4 ;preserving "Y" since will be killed downstream
+5 MERGE HBHCSAVY=Y
+6 SET DIE="^HBHC(631,"
SET DA=HBHCDFN
+7 SET DR(2,631.01)=1
SET DR="K HBHCQ;88;S:X'=""Y"" Y=""@1"";89;90;@1;"
+8 LOCK +^HBHC(631,HBHCDFN):0
IF $TEST
DO ^DIE
+9 MERGE Y=HBHCSAVY
End DoDot:1
+10 ;
MFHNO ;Either the site does not have medical foster homes,
+1 ;or this patient is not in a medical foster home.
+2 ;In that case, the Parent Site prompt is presented.
+3 IF $PIECE($GET(^HBHC(631,HBHCDFN,3)),"^")'="Y"
Begin DoDot:1
+4 ;This section called only if patient is not an MFH patient.
+5 ;HBH*1.0*32: add PARENT SITE (#91) field
+6 ;set a default if there is only one parent site defined
+7 ;at this site
+8 NEW HBHCPARN,HBHCSAVY
+9 ;saving original value of Y since used further down by pre-HBH*1.0*32 code
+10 MERGE HBHCSAVY=Y
+11 SET HBHCPARN=$SELECT($PIECE(^HBHC(631.9,1,1,0),"^",4)=1:$ORDER(^HBHC(631.9,1,1,"B","")),1:"")
+12 IF HBHCPARN]""
SET HBHCPARN=$PIECE(^DG(40.8,HBHCPARN,0),"^")
+13 SET DR="91//^S X=HBHCPARN"
+14 SET DIE="^HBHC(631,"
SET DA=HBHCDFN
+15 LOCK +^HBHC(631,HBHCDFN):0
IF $TEST
DO ^DIE
LOCK -^HBHC(631,HBHCDFN)
+16 MERGE Y=HBHCSAVY
+17 ;end of HBH*1.0*32
End DoDot:1
CONT ;end of MFH logic - continue with prompts, etc.
+1 ;Parent site is required if not a MFH patient.
+2 ;Parent site is not required for MFH patients since the MFH's parent site
+3 ;is retrieved for AITC transmissions.
+4 NEW HBHCQUIT
+5 SET HBHCQUIT=1
+6 ;Is parent site defined - if yes, may continue with prompts.
+7 IF $PIECE($GET(^HBHC(631,HBHCDFN,5)),"^")]""
SET HBHCQUIT=0
+8 ;If no parent site and this is an MFH site, the patient needs to be defined
+9 ;as an MFH patient if there is no parent site in ^HBHC(631,HBHCDFN,5).
+10 IF HBHCQUIT
IF $DATA(HBHCMFHS)
IF $PIECE($GET(^HBHC(631,HBHCDFN,3)),"^")="Y"
SET HBHCQUIT=0
+11 if HBHCQUIT
QUIT
+12 DO DEMO
+13 KILL DIE
SET DIE="^HBHC(631,"
SET DA=HBHCDFN
SET DIE("NO^")="OUTOK"
+14 ;added M code for Dx validation based on admission date
+15 ;added M code for Dx lookup instead of field 18
+16 SET DR="K HBHCQ;17;2:5;D BIRTHYR^HBHCUTL1;7;D SEXRACE^HBHCUTL1;10:13;14;D ACTION^HBHCUTL;15;16"
+17 LOCK +^HBHC(631,HBHCDFN):0
IF $TEST
DO ^DIE
+18 IF $DATA(Y)>0
GOTO PROMPT
+19 ; For ICD-9 lookups, set key variables used by special lookup routine
+20 SET ICDVDT=$PIECE(^HBHC(631,DA,0),U,18)
+21 SET ICDSYS=+$$SINFO^ICDEX("DIAG",ICDVDT)
+22 IF ICDSYS=1
SET ICDFMT=1
+23 IF '$DATA(HBHCMFHS)
Begin DoDot:1
+24 SET DR=$SELECT(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
End DoDot:1
+25 IF $DATA(HBHCMFHS)
Begin DoDot:1
+26 SET DR=$SELECT(ICDSYS=1:"I $D(HBHCQ) K HBHCQ S Y=37;18;68;19:36;37:38;67",1:"I $D(HBHCQ) K HBHCQ S Y=37;D ADMDX^HBHCLKU1;68;19:36;37:38;67")
End DoDot:1
+27 DO ^DIE
+28 LOCK -^HBHC(631,HBHCDFN)
KILL ICDVDT,ICDSYS,ICDFMT
GOTO PROMPT
+29 WRITE $CHAR(7),!!,"Another user is editing this entry.",!!
GOTO PROMPT
EXIT ; Exit module
+1 KILL DA,DIC,DIE,DIK,DR,HBHCAFLG,HBHCBXRF,HBHCCNTY,HBHCDFN,HBHCDPT,HBHCDPT0,HBHCEL,HBHCELGE,HBHCFLG,HBHCFORM,HBHCI,HBHCIEN,HBHCINFO,HBHCJ,HBHCMARE,HBHCMFHS,HBHCMS,HBHCNHSP,HBHCNOD0,HBHCPRCT,HBHCPS,HBHCPSRV,HBHCQ,HBHCRFLG,HBHCST
+2 KILL HBHCXMT3,HBHCWRD1,HBHCWRD2,HBHCWRD3,HBHCY0,HBHCZIP,VAEL,X,Y
+3 QUIT
CHECK ; Check previous episode(s) of care for 'Reject' in Admit/Reject Action or Discharge Date to ensure completed episode of care before allowing another episode of care to be created
+1 if ($PIECE(^HBHC(631,HBHCBXRF,0),U,15)=2)!($PIECE(^HBHC(631,HBHCBXRF,0),U,40)]"")
QUIT
+2 WRITE $CHAR(7),!!,"Patient must be discharged from last episode of care before new episode",!,"can be entered. Current episode not created.",!
HANG 3
+3 KILL DIK
SET DIK="^HBHC(631,"
SET DA=HBHCDFN
DO ^DIK
+4 SET HBHCFLG=1
+5 QUIT
DEMO ; Obtain patient demographic info
+1 SET (HBHCST,HBHCCNTY,HBHCZIP,HBHCEL,HBHCELGE,HBHCPS,HBHCPSRV,HBHCMS,HBHCMARE)=""
+2 IF $DATA(^DPT(HBHCDPT,.11))
SET HBHCINFO=^DPT(HBHCDPT,.11)
SET HBHCCNTY=$PIECE(HBHCINFO,U,7)
SET HBHCZIP=$PIECE(HBHCINFO,U,12)
SET HBHCST=$PIECE(HBHCINFO,U,5)
+3 ;p35
SET HBHCIEN=""
if HBHCST
SET HBHCIEN=$ORDER(^HBHC(631.8,"B",HBHCST,HBHCIEN))
SET HBHCST=$SELECT($GET(HBHCIEN):HBHCIEN,1:"")
+4 IF $DATA(^DPT(HBHCDPT,.36))
SET DFN=HBHCDPT
DO ELIG^VADPT
SET HBHCEL=+VAEL(1)
SET HBHCELGE=$SELECT(HBHCEL=1:"01",HBHCEL=2:"02",HBHCEL=16:"02",HBHCEL=11:"03",HBHCEL=4:"04",1:"05")
KILL DFN
+5 IF $DATA(^DPT(HBHCDPT,.32))
SET HBHCINFO=^DPT(HBHCDPT,.32)
SET HBHCPS=$PIECE(HBHCINFO,U,3)
SET HBHCPSRV=$SELECT(((HBHCPS>0)&(HBHCPS<9)):HBHCPS,HBHCPS=9:10,HBHCPS=121:11,1:"")
+6 SET HBHCINFO=^DPT(HBHCDPT,0)
SET HBHCMS=$PIECE(HBHCINFO,U,5)
SET HBHCMARE=$SELECT(HBHCMS=1:4,HBHCMS=2:1,HBHCMS=4:2,HBHCMS=5:3,HBHCMS=6:5,1:"")
+7 IF HBHCST]""
if ($PIECE(HBHCNOD0,U,3)="")&($DATA(^HBHC(631.8,HBHCST,0)))
SET $PIECE(^HBHC(631,HBHCDFN,0),U,3)=HBHCST
IF (HBHCCNTY]"")&($PIECE(HBHCNOD0,U,4)="")
if $DATA(^HBHC(631.8,HBHCST,0))
SET $PIECE(^HBHC(631,HBHCDFN,0),U,4)=HBHCCNTY
+8 if (HBHCZIP]"")&(($PIECE(HBHCNOD0,U,5)="")!($PIECE(HBHCNOD0,U,5)'?9N))
SET $PIECE(^HBHC(631,HBHCDFN,0),U,5)=HBHCZIP
+9 if (HBHCELGE]"")&($PIECE(HBHCNOD0,U,6)="")
SET $PIECE(^HBHC(631,HBHCDFN,0),U,6)=HBHCELGE
+10 if (HBHCPSRV]"")&($PIECE(HBHCNOD0,U,8)="")
SET $PIECE(^HBHC(631,HBHCDFN,0),U,8)=HBHCPSRV
+11 if (HBHCMARE]"")&($PIECE(HBHCNOD0,U,11)="")
SET $PIECE(^HBHC(631,HBHCDFN,0),U,11)=HBHCMARE
+12 QUIT
