HBHCUTL5 ; LR VAMC(IRMS)/MJT - HBHC Medical Foster Home (MFH) Rate Paid report utility module; Dec 2007
;;1.0;HOSPITAL BASED HOME CARE;**24,33**;NOV 01, 1993;Build 4
; Entry points: EN, EXIT, MFH, PT, PRTPT, PRTMFH
; Called by: ^HBHCRP28 & ^HBHCTXT
EN ; Entry point; user selects: patient or MFH; active only, individual, or all pts or MFHs; current rate paid only or entire rate paid history
; Prompt for patient or MFH report
K DIR S DIR(0)="SB^P:Patient;M:Medical Foster Home (MFH)",DIR("A")="Sort by Patient or Medical Foster Home (MFH)",DIR("?")="Enter P for Patient or M for Medical Foster Home (MFH) for sorting the report." D ^DIR
G:$D(DIRUT) EXIT
S HBHCXREF=$S(Y="P":"AJ",1:"AK"),HBHCWHO=$S(HBHCXREF="AJ":" Patient(s)",1:" MFH(s)")
; Prompt for inclusion of Active ONLY, Individual, or All
K DIR S DIR(0)="SB^O:Active ONLY;I:Individual;A:All",DIR("A")="Include: Active ONLY, Individual, or All "_HBHCWHO
S DIR("?")="Enter O for Active ONLY, I for Individual, or A for All Patient(s) or Medical Foster Home(s) (MFHs) for inclusion on the report." D ^DIR
G:$D(DIRUT) EXIT
S HBHCDIR=$S(Y="O":"O",Y="I":"I",1:"A")
; Prompt for individual patient(s) or MFH(s)
I HBHCDIR="I" K DIC,HBHCTMP D PROMPT
K DIC
; Prompt for Current Rate Paid, or All
K DIR S DIR(0)="SB^C:Current Rate;A:All Rates Paid",DIR("A")="Include: Current Rate, or All Rates Paid"
S DIR("?")="Enter C for Current Rate, or A for All Rates Paid for inclusion on the report." D ^DIR
G:$D(DIRUT) EXIT
S HBHC=$S(Y="C":"C",1:"A")
; Prompt for inclusion of Discharged Patients on MFH sort
I HBHCXREF="AK" K DIR S DIR(0)="SB^Y:Yes;N:No",DIR("A")="Include: Discharged Patients",DIR("?")="Enter Y to Include Discharged Patients, or N to omit them from inclusion on the report." D ^DIR
I HBHCXREF="AK" G:$D(DIRUT) EXIT S HBHCYN=$S(Y="Y":"Y",1:"N")
Q
EXIT ; Exit module
D ^%ZISC
K DIC,DIR,HBHC,HBHC1,HBHC2,HBHC3,HBHCCC,HBHCCNT,HBHCCOLM,HBHCCURJ,HBHCCURK,HBHCCURL,HBHCDIR,HBHCDLMT,HBHCDPT0,HBHCHDR,HBHCHDRX,HBHCHEAD,HBHCHI,HBHCI,HBHCINFO,HBHCJ,HBHCK,HBHCL,HBHCLOW,HBHCMFHN,HBHCMFHP,HBHCM,HBHCPAGE,HBHCTDY
K HBHCTMP,HBHCTOT,HBHCTXT,HBHCWHO,HBHCXREF,HBHCY,HBHCYN,HBHCZ,X,Y,^TMP("HBHC",$J)
Q
PROMPT ; Prompt user for individual Patient or Medical Foster Home (MFH) name
I HBHCXREF="AJ" S DIC="^HBHC(631,",DIC("S")="I $P($G(^HBHC(631,Y,3)),U)=""Y"""
I HBHCXREF="AK" S DIC="^HBHC(633.2,"
S DIC(0)="AEMQZ"
DIC ; Call ^DIC
D ^DIC
Q:(Y=-1)!($D(DTOUT))!($D(DUOUT))
S HBHCTMP(+Y)="" G DIC
Q
PT ; Process Patient
D:HBHCDIR="I" INDPT
D:HBHCDIR'="I" ALLPT
Q
INDPT ; Process Individual Patients
S HBHCI=0 F S HBHCI=$O(HBHCTMP(HBHCI)) Q:HBHCI'>0 D RATE
Q
ALLPT ; Process All or Active ONLY Patients
S HBHCI=0 F S HBHCI=$O(^HBHC(631,"AJ","Y",HBHCI)) Q:HBHCI'>0 D:HBHCDIR'="O" RATE D:(HBHCDIR="O")&($P(^HBHC(631,HBHCI,0),U,40)="") RATE
Q
MFH ; Process Medical Foster Home (MFH)
D:HBHCDIR="I" INDMFH
D:HBHCDIR'="I" ALLMFH
Q
INDMFH ; Process Individual Medical Foster Home (MFH)
S HBHCL=0 F S HBHCL=$O(HBHCTMP(HBHCL)) Q:HBHCL'>0 I $D(^HBHC(631,"AK",HBHCL)) S HBHCCURL=HBHCL S HBHCI=0 F S HBHCI=$O(^HBHC(631,"AK",HBHCL,HBHCI)) Q:HBHCI'>0 D RATE
Q
ALLMFH ; Process All or Active ONLY Medical Foster Homes (MFH)
S HBHCL=0 F S HBHCL=$O(^HBHC(633.2,HBHCL)) Q:HBHCL'>0 I $D(^HBHC(631,"AK",HBHCL)) S HBHCCURL=HBHCL S HBHCI=0 F S HBHCI=$O(^HBHC(631,"AK",HBHCL,HBHCI)) Q:HBHCI'>0 D:HBHCDIR'="O" RATE D:(HBHCDIR="O")&($P(^HBHC(633.2,HBHCL,0),U,6)="") RATE
Q
RATE ; Process Rate Multiple
; MFH sort => Q:Discharged patients are to be omitted
I HBHCXREF="AK" I HBHCYN="N" Q:($P(^HBHC(631,HBHCI,0),U,40)]"")
S HBHCCURJ="3000000" ;initialize to "00-00-00" for no date
D:HBHC="A" ALLRATE
D:HBHC="C" CURRATE
Q
ALLRATE ; Process All Rates
S HBHCJ=0 F S HBHCJ=$O(^HBHC(631,HBHCI,4,"B",HBHCJ)) Q:HBHCJ'>0 S HBHCK=0 F S HBHCK=$O(^HBHC(631,HBHCI,4,"B",HBHCJ,HBHCK)) Q:HBHCK'>0 D REPORT
Q
CURRATE ; Process Current Rate Only
S HBHCJ=0 F S HBHCJ=$O(^HBHC(631,HBHCI,4,"B",HBHCJ)) Q:HBHCJ'>0 S HBHCCURJ=HBHCJ,HBHCK=0 F S HBHCK=$O(^HBHC(631,HBHCI,4,"B",HBHCJ,HBHCK)) Q:HBHCK'>0 S HBHCCURK=HBHCK
S:'$D(HBHCCURK) HBHCCURK=0 D REPORT
Q
REPORT ; Set TMP for report format
S HBHCDPT0=$G(^DPT($P(^HBHC(631,HBHCI,0),U),0))
S:HBHCXREF="AJ" HBHCMFHP=$P($G(^HBHC(631,HBHCI,3)),U,2)
;HBH*1.01*33 - Add $G for ^HBHC(631 references
I HBHCXREF="AJ" S:HBHCDPT0]"" ^TMP("HBHC",$J,$P(HBHCDPT0,U),HBHCI,$S(HBHC="A":HBHCJ,1:HBHCCURJ),$S(HBHC="A":HBHCK,1:HBHCCURK))=$P($G(^HBHC(631,HBHCI,4,$S(HBHC="A":HBHCK,1:HBHCCURK),0)),U,2)_U_$E($P(HBHCDPT0,U,9),6,9)_U_HBHCMFHP
S:(HBHCXREF="AK")&(HBHCDPT0]"") HBHCMFHN=$P($G(^HBHC(633.2,$S(HBHC="A":HBHCL,1:HBHCCURL),0)),U)
I HBHCXREF="AK" S:(HBHCDPT0]"")&(HBHCMFHN]"") ^TMP("HBHC",$J,HBHCMFHN,$P(HBHCDPT0,U),HBHCI,$S(HBHC="A":HBHCJ,1:HBHCCURJ),$S(HBHC="A":HBHCK,1:HBHCCURK))=$P($G(^HBHC(631,HBHCI,4,$S(HBHC="A":HBHCK,1:HBHCCURK),0)),U,2)_U_$E($P(HBHCDPT0,U,9),6,9)
Q
PRTPT ; Print loop for Patient sort
S HBHCM="" F S HBHCM=$O(^TMP("HBHC",$J,HBHCM)) Q:HBHCM="" S HBHCI="" F S HBHCI=$O(^TMP("HBHC",$J,HBHCM,HBHCI)) Q:HBHCI="" W:(HBHCCNT>0)&('$D(HBHCTXT)) !,HBHCY S HBHCJ="" F S HBHCJ=$O(^TMP("HBHC",$J,HBHCM,HBHCI,HBHCJ)) Q:HBHCJ="" D CONTPT
Q
CONTPT ; Cont Patient Loop
S HBHCK="" F S HBHCK=$O(^TMP("HBHC",$J,HBHCM,HBHCI,HBHCJ,HBHCK)) Q:HBHCK="" S HBHCINFO=^TMP("HBHC",$J,HBHCM,HBHCI,HBHCJ,HBHCK) D:'$D(HBHCTXT) PRINTPT^HBHCRP28 D:$D(HBHCTXT) TXT^HBHCTXT
Q
PRTMFH ; Print loop for MFH sort
S HBHCL="" F S HBHCL=$O(^TMP("HBHC",$J,HBHCL)) Q:HBHCL="" S HBHCM="" F S HBHCM=$O(^TMP("HBHC",$J,HBHCL,HBHCM)) Q:HBHCM="" S HBHCI="" F S HBHCI=$O(^TMP("HBHC",$J,HBHCL,HBHCM,HBHCI)) Q:HBHCI="" W:(HBHCCNT>0)&('$D(HBHCTXT)) !,HBHCY D CONTMFH
Q
CONTMFH ; Cont MFH Loop
S HBHCJ="" F S HBHCJ=$O(^TMP("HBHC",$J,HBHCL,HBHCM,HBHCI,HBHCJ)) Q:HBHCJ="" D CONTMFH2
Q
CONTMFH2 ; Cont MFH Loop again...
S HBHCK="" F S HBHCK=$O(^TMP("HBHC",$J,HBHCL,HBHCM,HBHCI,HBHCJ,HBHCK)) Q:HBHCK="" S HBHCINFO=^TMP("HBHC",$J,HBHCL,HBHCM,HBHCI,HBHCJ,HBHCK) D:'$D(HBHCTXT) PRINTMFH^HBHCRP28 D:$D(HBHCTXT) TXT^HBHCTXT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHBHCUTL5 6125 printed Dec 13, 2024@01:58:52 Page 2
HBHCUTL5 ; LR VAMC(IRMS)/MJT - HBHC Medical Foster Home (MFH) Rate Paid report utility module; Dec 2007
+1 ;;1.0;HOSPITAL BASED HOME CARE;**24,33**;NOV 01, 1993;Build 4
+2 ; Entry points: EN, EXIT, MFH, PT, PRTPT, PRTMFH
+3 ; Called by: ^HBHCRP28 & ^HBHCTXT
EN ; Entry point; user selects: patient or MFH; active only, individual, or all pts or MFHs; current rate paid only or entire rate paid history
+1 ; Prompt for patient or MFH report
+2 KILL DIR
SET DIR(0)="SB^P:Patient;M:Medical Foster Home (MFH)"
SET DIR("A")="Sort by Patient or Medical Foster Home (MFH)"
SET DIR("?")="Enter P for Patient or M for Medical Foster Home (MFH) for sorting the report."
DO ^DIR
+3 if $DATA(DIRUT)
GOTO EXIT
+4 SET HBHCXREF=$SELECT(Y="P":"AJ",1:"AK")
SET HBHCWHO=$SELECT(HBHCXREF="AJ":" Patient(s)",1:" MFH(s)")
+5 ; Prompt for inclusion of Active ONLY, Individual, or All
+6 KILL DIR
SET DIR(0)="SB^O:Active ONLY;I:Individual;A:All"
SET DIR("A")="Include: Active ONLY, Individual, or All "_HBHCWHO
+7 SET DIR("?")="Enter O for Active ONLY, I for Individual, or A for All Patient(s) or Medical Foster Home(s) (MFHs) for inclusion on the report."
DO ^DIR
+8 if $DATA(DIRUT)
GOTO EXIT
+9 SET HBHCDIR=$SELECT(Y="O":"O",Y="I":"I",1:"A")
+10 ; Prompt for individual patient(s) or MFH(s)
+11 IF HBHCDIR="I"
KILL DIC,HBHCTMP
DO PROMPT
+12 KILL DIC
+13 ; Prompt for Current Rate Paid, or All
+14 KILL DIR
SET DIR(0)="SB^C:Current Rate;A:All Rates Paid"
SET DIR("A")="Include: Current Rate, or All Rates Paid"
+15 SET DIR("?")="Enter C for Current Rate, or A for All Rates Paid for inclusion on the report."
DO ^DIR
+16 if $DATA(DIRUT)
GOTO EXIT
+17 SET HBHC=$SELECT(Y="C":"C",1:"A")
+18 ; Prompt for inclusion of Discharged Patients on MFH sort
+19 IF HBHCXREF="AK"
KILL DIR
SET DIR(0)="SB^Y:Yes;N:No"
SET DIR("A")="Include: Discharged Patients"
SET DIR("?")="Enter Y to Include Discharged Patients, or N to omit them from inclusion on the report."
DO ^DIR
+20 IF HBHCXREF="AK"
if $DATA(DIRUT)
GOTO EXIT
SET HBHCYN=$SELECT(Y="Y":"Y",1:"N")
+21 QUIT
EXIT ; Exit module
+1 DO ^%ZISC
+2 KILL DIC,DIR,HBHC,HBHC1,HBHC2,HBHC3,HBHCCC,HBHCCNT,HBHCCOLM,HBHCCURJ,HBHCCURK,HBHCCURL,HBHCDIR,HBHCDLMT,HBHCDPT0,HBHCHDR,HBHCHDRX,HBHCHEAD,HBHCHI,HBHCI,HBHCINFO,HBHCJ,HBHCK,HBHCL,HBHCLOW,HBHCMFHN,HBHCMFHP,HBHCM,HBHCPAGE,HBHCTDY
+3 KILL HBHCTMP,HBHCTOT,HBHCTXT,HBHCWHO,HBHCXREF,HBHCY,HBHCYN,HBHCZ,X,Y,^TMP("HBHC",$JOB)
+4 QUIT
PROMPT ; Prompt user for individual Patient or Medical Foster Home (MFH) name
+1 IF HBHCXREF="AJ"
SET DIC="^HBHC(631,"
SET DIC("S")="I $P($G(^HBHC(631,Y,3)),U)=""Y"""
+2 IF HBHCXREF="AK"
SET DIC="^HBHC(633.2,"
+3 SET DIC(0)="AEMQZ"
DIC ; Call ^DIC
+1 DO ^DIC
+2 if (Y=-1)!($DATA(DTOUT))!($DATA(DUOUT))
QUIT
+3 SET HBHCTMP(+Y)=""
GOTO DIC
+4 QUIT
PT ; Process Patient
+1 if HBHCDIR="I"
DO INDPT
+2 if HBHCDIR'="I"
DO ALLPT
+3 QUIT
INDPT ; Process Individual Patients
+1 SET HBHCI=0
FOR
SET HBHCI=$ORDER(HBHCTMP(HBHCI))
if HBHCI'>0
QUIT
DO RATE
+2 QUIT
ALLPT ; Process All or Active ONLY Patients
+1 SET HBHCI=0
FOR
SET HBHCI=$ORDER(^HBHC(631,"AJ","Y",HBHCI))
if HBHCI'>0
QUIT
if HBHCDIR'="O"
DO RATE
if (HBHCDIR="O")&($PIECE(^HBHC(631,HBHCI,0),U,40)="")
DO RATE
+2 QUIT
MFH ; Process Medical Foster Home (MFH)
+1 if HBHCDIR="I"
DO INDMFH
+2 if HBHCDIR'="I"
DO ALLMFH
+3 QUIT
INDMFH ; Process Individual Medical Foster Home (MFH)
+1 SET HBHCL=0
FOR
SET HBHCL=$ORDER(HBHCTMP(HBHCL))
if HBHCL'>0
QUIT
IF $DATA(^HBHC(631,"AK",HBHCL))
SET HBHCCURL=HBHCL
SET HBHCI=0
FOR
SET HBHCI=$ORDER(^HBHC(631,"AK",HBHCL,HBHCI))
if HBHCI'>0
QUIT
DO RATE
+2 QUIT
ALLMFH ; Process All or Active ONLY Medical Foster Homes (MFH)
+1 SET HBHCL=0
FOR
SET HBHCL=$ORDER(^HBHC(633.2,HBHCL))
if HBHCL'>0
QUIT
IF $DATA(^HBHC(631,"AK",HBHCL))
SET HBHCCURL=HBHCL
SET HBHCI=0
FOR
SET HBHCI=$ORDER(^HBHC(631,"AK",HBHCL,HBHCI))
if HBHCI'>0
QUIT
if HBHCDIR'="O"
DO RATE
if (HBHCDIR="O")&($PIECE(^HBHC(633.2,HBHCL,0),U,6)="")
DO RATE
+2 QUIT
RATE ; Process Rate Multiple
+1 ; MFH sort => Q:Discharged patients are to be omitted
+2 IF HBHCXREF="AK"
IF HBHCYN="N"
if ($PIECE(^HBHC(631,HBHCI,0),U,40)]"")
QUIT
+3 ;initialize to "00-00-00" for no date
SET HBHCCURJ="3000000"
+4 if HBHC="A"
DO ALLRATE
+5 if HBHC="C"
DO CURRATE
+6 QUIT
ALLRATE ; Process All Rates
+1 SET HBHCJ=0
FOR
SET HBHCJ=$ORDER(^HBHC(631,HBHCI,4,"B",HBHCJ))
if HBHCJ'>0
QUIT
SET HBHCK=0
FOR
SET HBHCK=$ORDER(^HBHC(631,HBHCI,4,"B",HBHCJ,HBHCK))
if HBHCK'>0
QUIT
DO REPORT
+2 QUIT
CURRATE ; Process Current Rate Only
+1 SET HBHCJ=0
FOR
SET HBHCJ=$ORDER(^HBHC(631,HBHCI,4,"B",HBHCJ))
if HBHCJ'>0
QUIT
SET HBHCCURJ=HBHCJ
SET HBHCK=0
FOR
SET HBHCK=$ORDER(^HBHC(631,HBHCI,4,"B",HBHCJ,HBHCK))
if HBHCK'>0
QUIT
SET HBHCCURK=HBHCK
+2 if '$DATA(HBHCCURK)
SET HBHCCURK=0
DO REPORT
+3 QUIT
REPORT ; Set TMP for report format
+1 SET HBHCDPT0=$GET(^DPT($PIECE(^HBHC(631,HBHCI,0),U),0))
+2 if HBHCXREF="AJ"
SET HBHCMFHP=$PIECE($GET(^HBHC(631,HBHCI,3)),U,2)
+3 ;HBH*1.01*33 - Add $G for ^HBHC(631 references
+4 IF HBHCXREF="AJ"
if HBHCDPT0]""
SET ^TMP("HBHC",$JOB,$PIECE(HBHCDPT0,U),HBHCI,$SELECT(HBHC="A":HBHCJ,1:HBHCCURJ),$SELECT(HBHC="A":HBHCK,1:HBHCCURK))=$PIECE($GET(^HBHC(631,HBHCI,4,$SELECT(HBHC="A":HBHCK,1:HBHCCURK),0)),U,2)_U_$EXTRACT($PIECE(HBHCDPT0,U,9),6,9)_U_HBHCMF
HP
+5 if (HBHCXREF="AK")&(HBHCDPT0]"")
SET HBHCMFHN=$PIECE($GET(^HBHC(633.2,$SELECT(HBHC="A":HBHCL,1:HBHCCURL),0)),U)
+6 IF HBHCXREF="AK"
if (HBHCDPT0]"")&(HBHCMFHN]"")
SET ^TMP("HBHC",$JOB,HBHCMFHN,$PIECE(HBHCDPT0,U),HBHCI,$SELECT(HBHC="A":HBHCJ,1:HBHCCURJ),$SELECT(HBHC="A":HBHCK,1:HBHCCURK))=$PIECE($GET(^HBHC(631,HBHCI,4,$SELECT(HBHC="A":HBHCK,1:HBHCCURK),0)),U,2)_U_$EXTRACT($PIECE(HBHCDPT0,U,9),6,9)
+7 QUIT
PRTPT ; Print loop for Patient sort
+1 SET HBHCM=""
FOR
SET HBHCM=$ORDER(^TMP("HBHC",$JOB,HBHCM))
if HBHCM=""
QUIT
SET HBHCI=""
FOR
SET HBHCI=$ORDER(^TMP("HBHC",$JOB,HBHCM,HBHCI))
if HBHCI=""
QUIT
if (HBHCCNT>0)&('$DATA(HBHCTXT))
WRITE !,HBHCY
SET HBHCJ=""
FOR
SET HBHCJ=$ORDER(^TMP("HBHC",$JOB,HBHCM,HBHCI,HBHCJ))
if HBHCJ=""
QUIT
DO CONTPT
+2 QUIT
CONTPT ; Cont Patient Loop
+1 SET HBHCK=""
FOR
SET HBHCK=$ORDER(^TMP("HBHC",$JOB,HBHCM,HBHCI,HBHCJ,HBHCK))
if HBHCK=""
QUIT
SET HBHCINFO=^TMP("HBHC",$JOB,HBHCM,HBHCI,HBHCJ,HBHCK)
if '$DATA(HBHCTXT)
DO PRINTPT^HBHCRP28
if $DATA(HBHCTXT)
DO TXT^HBHCTXT
+2 QUIT
PRTMFH ; Print loop for MFH sort
+1 SET HBHCL=""
FOR
SET HBHCL=$ORDER(^TMP("HBHC",$JOB,HBHCL))
if HBHCL=""
QUIT
SET HBHCM=""
FOR
SET HBHCM=$ORDER(^TMP("HBHC",$JOB,HBHCL,HBHCM))
if HBHCM=""
QUIT
SET HBHCI=""
FOR
SET HBHCI=$ORDER(^TMP("HBHC",$JOB,HBHCL,HBHCM,HBHCI))
if HBHCI=""
QUIT
if (HBHCCNT>0)&('$DATA(HBHCTXT))
WRITE !,HBHCY
DO CONTMFH
+2 QUIT
CONTMFH ; Cont MFH Loop
+1 SET HBHCJ=""
FOR
SET HBHCJ=$ORDER(^TMP("HBHC",$JOB,HBHCL,HBHCM,HBHCI,HBHCJ))
if HBHCJ=""
QUIT
DO CONTMFH2
+2 QUIT
CONTMFH2 ; Cont MFH Loop again...
+1 SET HBHCK=""
FOR
SET HBHCK=$ORDER(^TMP("HBHC",$JOB,HBHCL,HBHCM,HBHCI,HBHCJ,HBHCK))
if HBHCK=""
QUIT
SET HBHCINFO=^TMP("HBHC",$JOB,HBHCL,HBHCM,HBHCI,HBHCJ,HBHCK)
if '$DATA(HBHCTXT)
DO PRINTMFH^HBHCRP28
if $DATA(HBHCTXT)
DO TXT^HBHCTXT
+2 QUIT
