- 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 Feb 18, 2025@23:25:16 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