HBHCRP2 ;LR VAMC(IRMS)/MJT - HBHC report on file 631; May 22, 2021@14:49
;;1.0;HOSPITAL BASED HOME CARE;**1,2,5,6,9,19,22,25,32**;NOV 01, 1993;Build 58
;
; This routine references the following supported ICRs:
; 5747 $$CODEC^ICDEX
;
PROMPT ; Prompt user for patient name
K DIC S DIC="^HBHC(631,",DIC(0)="AEMQZ" D ^DIC
G:Y=-1 EXIT
S HBHCDFN=+Y,HBHCY0=Y(0),%ZIS="Q" K IOP,ZTIO,ZTSAVE D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="DQ^HBHCRP2",ZTDESC="HBPC Patient Evaluation/Admission Data Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT
DQ ; De-queue
U IO
N HBHCHOSPX
S HBHCHOSPX=""
;Find patient's parent site
D PARENT^HBHCUTL1
;strip off spaces added by HBHCUTL1
S HBHCHOSPX=$P(HBHCHOSPX," ")
;If patient does not have a parent site, use default site.
;(The patient might have been admitted before the install of HBH*1.0*32.)
I HBHCHOSPX="" S HBHCHOSPX=$S($P(^HBHC(631.9,1,0),U,5)]"":$E($P($G(^DIC(4,$P(^HBHC(631.9,1,0),U,5),99)),U),1,7),1:"")
S $P(HBHCY,"-",81)="",HBHCHEAD="Patient Evaluation/Admission Data",HBHCCOLM=(80-(20+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1
D TODAY^HBHCUTL
W ?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<" W !!,"Run Date: ",HBHCTDY,!!,HBHCZ
PROCESS ; Process record
S HBHCDPT0=^DPT(+(HBHCY0),0),HBHCNOD1=$G(^HBHC(631,HBHCDFN,1))
W !,"Patient Name: ",$P(HBHCDPT0,U),?46,"Last Four:",?58,$E($P(HBHCDPT0,U,9),6,9),!,HBHCZ
;HBH*1.0*32 - Display patient's parent site as Hospital Number.
W !," 1. Hospital Number:",?29,$J(HBHCHOSPX,7)
W ?38,"|",?41,"20. Primary Diagnosis @ Adm:",?72,$J($S($P(HBHCY0,U,19)]"":$$CODEC^ICDEX(80,$P(HBHCY0,U,19)),1:""),8),!,HBHCY
W !," 2. Date:",?28,$S($P(HBHCY0,U,18)]"":$E($P(HBHCY0,U,18),4,5)_"-"_$E($P(HBHCY0,U,18),6,7)_"-"_$E($P(HBHCY0,U,18),2,3),$P(HBHCY0,U,2)]"":$E($P(HBHCY0,U,2),4,5)_"-"_$E($P(HBHCY0,U,2),6,7)_"-"_$E($P(HBHCY0,U,2),2,3),1:"")
W ?38,"|",?41,"21. Secondary Diagnoses @ Adm:" I HBHCNOD1]"" W:$P(HBHCNOD1,U,14)]"" !?38,"|",?46,$P(HBHCNOD1,U,14)
W !,HBHCY
W !," 3. State Code:",?34,$S($P(HBHCY0,U,3)]"":$P(^DIC(5,(+^HBHC(631.8,($P(HBHCY0,U,3)),0)),0),U,3),1:""),?38,"|",?41,"22. Vision @ Admission:",?79,$P(HBHCY0,U,20),!,HBHCY
S HBHCCNTY="" S:(($P(HBHCY0,U,3)]"")&($P(HBHCY0,U,4)]"")) HBHCCNTY=$P($G(^DIC(5,(+^HBHC(631.8,($P(HBHCY0,U,3)),0)),1,$P(HBHCY0,U,4),0)),U,3)
W !," 4. County Code:",?33,HBHCCNTY,?38,"|",?46,"Hearing @ Admission:",?79,$P(HBHCY0,U,21),!,HBHCY
W !," 5. ZIP Code:",?26,$J($E($P(HBHCY0,U,5),1,5)_$S($E($P(HBHCY0,U,5),6,9)]"":"-"_$E($P(HBHCY0,U,5),6,9),1:""),10),?38,"|",?41,"23. Expressive Communication @ Adm:",?79,$P(HBHCY0,U,22),!,HBHCY
W !," 6. Eligibility @ Evaluation:",?34,$P(HBHCY0,U,6),?38,"|",?41,"24. Receptive Communication @ Adm:",?79,$P(HBHCY0,U,23),!,HBHCY
W !," 7. Birth Year:",?32,$S($P(HBHCDPT0,U,3):1700+$E($P(HBHCDPT0,U,3),1,3),1:""),?38,"|",?41,"25. Bathing @ Admission:",?79,$P(HBHCY0,U,24),!,HBHCY
W !," 8. Period of Service:",?34,$S($P(HBHCY0,U,8)]"":$P($G(^HBHC(631.7,$P(HBHCY0,U,8),0)),U),1:""),?38,"|",?46,"Dressing @ Admission:",?79,$P(HBHCY0,U,25),!,HBHCY
W !," 9. Sex:",?35,$S($P(HBHCDPT0,U,2)="M":1,1:2),?38,"|",?46,"Toilet Usage @ Admission:",?79,$P(HBHCY0,U,26),!,HBHCY
; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference mjt
;S HBHCRC=$S($P(HBHCDPT0,U,6)]"":$P(^DIC(10,$P(HBHCDPT0,U,6),0),U,2),1:"")
;W !,"10. Race:",?35,$S(HBHCRC=6:1,HBHCRC=4:2,(HBHCRC=1)!(HBHCRC=2):3,HBHCRC=3:4,HBHCRC=5:5,1:9),?38,"|",?46,"Transferring @ Admission:",?79,$P(HBHCY0,U,27),!,HBHCY
; Field retained until VA Form 10-0014 modified to remove field mjt
W !,"10. Race: Obsolete Field Jan 2003",?38,"|",?46,"Transferring @ Admission:",?79,$P(HBHCY0,U,27),!,HBHCY
W !,"11. Marital Status @ Evaluation:",?35,$P(HBHCY0,U,11),?38,"|",?46,"Eating @ Admission:",?79,$P(HBHCY0,U,28),!,HBHCY
W !,"12. Living Arrangements @ Eval:",?35,$P(HBHCY0,U,12),?38,"|",?46,"Walking @ Admission:",?79,$P(HBHCY0,U,29),!,HBHCY
W !,"13. Last Agency Providing Care:",?35,$P(HBHCY0,U,13),?38,"|",?41,"26. Bowel Continence @ Admission:",?79,$P(HBHCY0,U,30),!,HBHCY
W !,"14. Type of Last Care Agency:",?35,$P(HBHCY0,U,14),?38,"|",?46,"Bladder Continence @ Admission:",?79,$P(HBHCY0,U,31),!,HBHCY
W !,"15. Referred While Inpatient:",?35,$P(HBHCNOD1,U,29),?38,"|",?41,"27. Mobility @ Admission:",?79,$P(HBHCY0,U,32),!,HBHCY
W !,"16. Admit/Reject Action:",?35,$P(HBHCY0,U,15),?38,"|",?41,"28. Adaptive Tasks @ Admission:",?79,$P(HBHCY0,U,33),!,HBHCY
W !,"17. Reject/Withdraw Reason:",?34,$S($P(HBHCY0,U,16)]"":$P(^HBHC(631.1,$P(HBHCY0,U,16),0),U),1:""),?38,"|",?41,"29. Behavior Problems @ Admission:",?79,$P(HBHCY0,U,34),!,HBHCY
W !,"18. Reject/Withdraw Disposition:",?35,$P(HBHCY0,U,17),?38,"|",?41,"30. Disorientation @ Admission:",?79,$P(HBHCY0,U,35),!,HBHCY
W !,"19. Last Four:",?25,$E($P(HBHCDPT0,U,9),6,9),?38,"|",?41,"31. Mood Disturbance @ Admission:",?79,$P(HBHCY0,U,36),!,HBHCY
W !?38,"|",?41,"32. Caregiver Limitations @ Adm:",?79,$P(HBHCY0,U,37),!,HBHCY
W !?38,"|",?41,"33. Person Completing Eval/Adm:",?76,$J($S($P(HBHCY0,U,38)]"":$P(^HBHC(631.4,$P(HBHCY0,U,38),0),U),1:""),4),!,HBHCY
W !?38,"|",?46,"Date Eval/Adm Completed:",?72,$S($P(HBHCY0,U,39)]"":$E($P(HBHCY0,U,39),4,5)_"-"_$E($P(HBHCY0,U,39),6,7)_"-"_$E($P(HBHCY0,U,39),2,3),1:""),!,HBHCY
W !?38,"|",?46,"Case Manager:",?76,$J($S($P(HBHCNOD1,U,13)]"":$P(^HBHC(631.4,$P(HBHCNOD1,U,13),0),U),1:""),4),!,HBHCY
EXIT ; Exit module
D ^%ZISC
K DIC,HBHCCNTY,HBHCCOLM,HBHCDFN,HBHCDPT0,HBHCHEAD,HBHCNOD1,HBHCRC,HBHCTDY,HBHCY,HBHCY0,HBHCZ,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCRP2 5577 printed Nov 22, 2024@17:08:32 Page 2
HBHCRP2 ;LR VAMC(IRMS)/MJT - HBHC report on file 631; May 22, 2021@14:49
+1 ;;1.0;HOSPITAL BASED HOME CARE;**1,2,5,6,9,19,22,25,32**;NOV 01, 1993;Build 58
+2 ;
+3 ; This routine references the following supported ICRs:
+4 ; 5747 $$CODEC^ICDEX
+5 ;
PROMPT ; Prompt user for patient name
+1 KILL DIC
SET DIC="^HBHC(631,"
SET DIC(0)="AEMQZ"
DO ^DIC
+2 if Y=-1
GOTO EXIT
+3 SET HBHCDFN=+Y
SET HBHCY0=Y(0)
SET %ZIS="Q"
KILL IOP,ZTIO,ZTSAVE
DO ^%ZIS
if POP
GOTO EXIT
+4 IF $DATA(IO("Q"))
SET ZTRTN="DQ^HBHCRP2"
SET ZTDESC="HBPC Patient Evaluation/Admission Data Report"
SET ZTSAVE("HBHC*")=""
DO ^%ZTLOAD
GOTO EXIT
DQ ; De-queue
+1 USE IO
+2 NEW HBHCHOSPX
+3 SET HBHCHOSPX=""
+4 ;Find patient's parent site
+5 DO PARENT^HBHCUTL1
+6 ;strip off spaces added by HBHCUTL1
+7 SET HBHCHOSPX=$PIECE(HBHCHOSPX," ")
+8 ;If patient does not have a parent site, use default site.
+9 ;(The patient might have been admitted before the install of HBH*1.0*32.)
+10 IF HBHCHOSPX=""
SET HBHCHOSPX=$SELECT($PIECE(^HBHC(631.9,1,0),U,5)]"":$EXTRACT($PIECE($GET(^DIC(4,$PIECE(^HBHC(631.9,1,0),U,5),99)),U),1,7),1:"")
+11 SET $PIECE(HBHCY,"-",81)=""
SET HBHCHEAD="Patient Evaluation/Admission Data"
SET HBHCCOLM=(80-(20+$LENGTH(HBHCHEAD))\2)
if HBHCCOLM'>0
SET HBHCCOLM=1
+12 DO TODAY^HBHCUTL
+13 WRITE ?HBHCCOLM,">>> HBPC ",HBHCHEAD," Report <<<"
WRITE !!,"Run Date: ",HBHCTDY,!!,HBHCZ
PROCESS ; Process record
+1 SET HBHCDPT0=^DPT(+(HBHCY0),0)
SET HBHCNOD1=$GET(^HBHC(631,HBHCDFN,1))
+2 WRITE !,"Patient Name: ",$PIECE(HBHCDPT0,U),?46,"Last Four:",?58,$EXTRACT($PIECE(HBHCDPT0,U,9),6,9),!,HBHCZ
+3 ;HBH*1.0*32 - Display patient's parent site as Hospital Number.
+4 WRITE !," 1. Hospital Number:",?29,$JUSTIFY(HBHCHOSPX,7)
+5 WRITE ?38,"|",?41,"20. Primary Diagnosis @ Adm:",?72,$JUSTIFY($SELECT($PIECE(HBHCY0,U,19)]"":$$CODEC^ICDEX(80,$PIECE(HBHCY0,U,19)),1:""),8),!,HBHCY
+6 WRITE !," 2. Date:",?28,$SELECT($PIECE(HBHCY0,U,18)]"":$EXTRACT($PIECE(HBHCY0,U,18),4,5)_"-"_$EXTRACT(...
... $PIECE(HBHCY0,U,18),6,7)_"-"_$EXTRACT($PIECE(HBHCY0,U,18),2,3),$PIECE(HBHCY0,U,2)]"":$EXTRACT($PIECE(HBHCY0,U,2),4,5)_"-"_$EXTRACT($PIECE(HBHCY0,U,2),6,7)_"-"_$EXTRACT($PIECE(HBHCY0,U,2),2,3),1:"")
+7 WRITE ?38,"|",?41,"21. Secondary Diagnoses @ Adm:"
IF HBHCNOD1]""
if $PIECE(HBHCNOD1,U,14)]""
WRITE !?38,"|",?46,$PIECE(HBHCNOD1,U,14)
+8 WRITE !,HBHCY
+9 WRITE !," 3. State Code:",?34,$SELECT($PIECE(HBHCY0,U,3)]"":$PIECE(^DIC(5,(+^HBHC(631.8,($PIECE(HBHCY0,U,3)),0)),0),U,3),1:""),?38,"|",?41,"22. Vision @ Admission:",?79,$PIECE(HBHCY0,U,20),!,HBHCY
+10 SET HBHCCNTY=""
if (($PIECE(HBHCY0,U,3)]"")&($PIECE(HBHCY0,U,4)]""))
SET HBHCCNTY=$PIECE($GET(^DIC(5,(+^HBHC(631.8,($PIECE(HBHCY0,U,3)),0)),1,$PIECE(HBHCY0,U,4),0)),U,3)
+11 WRITE !," 4. County Code:",?33,HBHCCNTY,?38,"|",?46,"Hearing @ Admission:",?79,$PIECE(HBHCY0,U,21),!,HBHCY
+12 WRITE !," 5. ZIP Code:",?26,$JUSTIFY($EXTRACT($PIECE(HBHCY0,U,5),1,5)_$SELECT($EXTRACT($PIECE(HBHCY0,U,5),6,9)]"":"-"_$EXTRACT($PIECE(HBHCY0,U,5),6,9),1:""),10),?38,"|",?41,"23. Expressive Communication @ Adm:",?79,$PIECE(HBHCY0,U,22),!,HBHCY
+13 WRITE !," 6. Eligibility @ Evaluation:",?34,$PIECE(HBHCY0,U,6),?38,"|",?41,"24. Receptive Communication @ Adm:",?79,$PIECE(HBHCY0,U,23),!,HBHCY
+14 WRITE !," 7. Birth Year:",?32,$SELECT($PIECE(HBHCDPT0,U,3):1700+$EXTRACT($PIECE(HBHCDPT0,U,3),1,3),1:""),?38,"|",?41,"25. Bathing @ Admission:",?79,$PIECE(HBHCY0,U,24),!,HBHCY
+15 WRITE !," 8. Period of Service:",?34,$SELECT($PIECE(HBHCY0,U,8)]"":$PIECE($GET(^HBHC(631.7,$PIECE(HBHCY0,U,8),0)),U),1:""),?38,"|",?46,"Dressing @ Admission:",?79,$PIECE(HBHCY0,U,25),!,HBHCY
+16 WRITE !," 9. Sex:",?35,$SELECT($PIECE(HBHCDPT0,U,2)="M":1,1:2),?38,"|",?46,"Toilet Usage @ Admission:",?79,$PIECE(HBHCY0,U,26),!,HBHCY
+17 ; Obsolete with Race/Ethnicity Info Jan 2003 mandate; commented out historical reference mjt
+18 ;S HBHCRC=$S($P(HBHCDPT0,U,6)]"":$P(^DIC(10,$P(HBHCDPT0,U,6),0),U,2),1:"")
+19 ;W !,"10. Race:",?35,$S(HBHCRC=6:1,HBHCRC=4:2,(HBHCRC=1)!(HBHCRC=2):3,HBHCRC=3:4,HBHCRC=5:5,1:9),?38,"|",?46,"Transferring @ Admission:",?79,$P(HBHCY0,U,27),!,HBHCY
+20 ; Field retained until VA Form 10-0014 modified to remove field mjt
+21 WRITE !,"10. Race: Obsolete Field Jan 2003",?38,"|",?46,"Transferring @ Admission:",?79,$PIECE(HBHCY0,U,27),!,HBHCY
+22 WRITE !,"11. Marital Status @ Evaluation:",?35,$PIECE(HBHCY0,U,11),?38,"|",?46,"Eating @ Admission:",?79,$PIECE(HBHCY0,U,28),!,HBHCY
+23 WRITE !,"12. Living Arrangements @ Eval:",?35,$PIECE(HBHCY0,U,12),?38,"|",?46,"Walking @ Admission:",?79,$PIECE(HBHCY0,U,29),!,HBHCY
+24 WRITE !,"13. Last Agency Providing Care:",?35,$PIECE(HBHCY0,U,13),?38,"|",?41,"26. Bowel Continence @ Admission:",?79,$PIECE(HBHCY0,U,30),!,HBHCY
+25 WRITE !,"14. Type of Last Care Agency:",?35,$PIECE(HBHCY0,U,14),?38,"|",?46,"Bladder Continence @ Admission:",?79,$PIECE(HBHCY0,U,31),!,HBHCY
+26 WRITE !,"15. Referred While Inpatient:",?35,$PIECE(HBHCNOD1,U,29),?38,"|",?41,"27. Mobility @ Admission:",?79,$PIECE(HBHCY0,U,32),!,HBHCY
+27 WRITE !,"16. Admit/Reject Action:",?35,$PIECE(HBHCY0,U,15),?38,"|",?41,"28. Adaptive Tasks @ Admission:",?79,$PIECE(HBHCY0,U,33),!,HBHCY
+28 WRITE !,"17. Reject/Withdraw Reason:",?34,$SELECT($PIECE(HBHCY0,U,16)]"":$PIECE(^HBHC(631.1,$PIECE(HBHCY0,U,16),0),U),1:""),?38,"|",?41,"29. Behavior Problems @ Admission:",?79,$PIECE(HBHCY0,U,34),!,HBHCY
+29 WRITE !,"18. Reject/Withdraw Disposition:",?35,$PIECE(HBHCY0,U,17),?38,"|",?41,"30. Disorientation @ Admission:",?79,$PIECE(HBHCY0,U,35),!,HBHCY
+30 WRITE !,"19. Last Four:",?25,$EXTRACT($PIECE(HBHCDPT0,U,9),6,9),?38,"|",?41,"31. Mood Disturbance @ Admission:",?79,$PIECE(HBHCY0,U,36),!,HBHCY
+31 WRITE !?38,"|",?41,"32. Caregiver Limitations @ Adm:",?79,$PIECE(HBHCY0,U,37),!,HBHCY
+32 WRITE !?38,"|",?41,"33. Person Completing Eval/Adm:",?76,$JUSTIFY($SELECT($PIECE(HBHCY0,U,38)]"":$PIECE(^HBHC(631.4,$PIECE(HBHCY0,U,38),0),U),1:""),4),!,HBHCY
+33 WRITE !?38,"|",?46,"Date Eval/Adm Completed:",?72,$SELECT($PIECE(HBHCY0,U,39)]"":$EXTRACT($PIECE(HBHCY0,U,39),4,5)_"-"_$EXTRACT($PIECE(HBHCY0,U,39),6,7)_"-"_$EXTRACT($PIECE(HBHCY0,U,39),2,3),1:""),!,HBHCY
+34 WRITE !?38,"|",?46,"Case Manager:",?76,$JUSTIFY($SELECT($PIECE(HBHCNOD1,U,13)]"":$PIECE(^HBHC(631.4,$PIECE(HBHCNOD1,U,13),0),U),1:""),4),!,HBHCY
EXIT ; Exit module
+1 DO ^%ZISC
+2 KILL DIC,HBHCCNTY,HBHCCOLM,HBHCDFN,HBHCDPT0,HBHCHEAD,HBHCNOD1,HBHCRC,HBHCTDY,HBHCY,HBHCY0,HBHCZ,Y
+3 QUIT
