Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HBHCUTL5

HBHCUTL5.m

Go to the documentation of this file.
  1. 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
  1. ; Entry points: EN, EXIT, MFH, PT, PRTPT, PRTMFH
  1. ; Called by: ^HBHCRP28 & ^HBHCTXT
  1. 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
  1. 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
  1. G:$D(DIRUT) EXIT
  1. S HBHCXREF=$S(Y="P":"AJ",1:"AK"),HBHCWHO=$S(HBHCXREF="AJ":" Patient(s)",1:" MFH(s)")
  1. ; Prompt for inclusion of Active ONLY, Individual, or All
  1. K DIR S DIR(0)="SB^O:Active ONLY;I:Individual;A:All",DIR("A")="Include: Active ONLY, Individual, or All "_HBHCWHO
  1. 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
  1. G:$D(DIRUT) EXIT
  1. S HBHCDIR=$S(Y="O":"O",Y="I":"I",1:"A")
  1. ; Prompt for individual patient(s) or MFH(s)
  1. I HBHCDIR="I" K DIC,HBHCTMP D PROMPT
  1. K DIC
  1. ; Prompt for Current Rate Paid, or All
  1. K DIR S DIR(0)="SB^C:Current Rate;A:All Rates Paid",DIR("A")="Include: Current Rate, or All Rates Paid"
  1. S DIR("?")="Enter C for Current Rate, or A for All Rates Paid for inclusion on the report." D ^DIR
  1. G:$D(DIRUT) EXIT
  1. S HBHC=$S(Y="C":"C",1:"A")
  1. ; Prompt for inclusion of Discharged Patients on MFH sort
  1. 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
  1. I HBHCXREF="AK" G:$D(DIRUT) EXIT S HBHCYN=$S(Y="Y":"Y",1:"N")
  1. Q
  1. EXIT ; Exit module
  1. D ^%ZISC
  1. 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
  1. K HBHCTMP,HBHCTOT,HBHCTXT,HBHCWHO,HBHCXREF,HBHCY,HBHCYN,HBHCZ,X,Y,^TMP("HBHC",$J)
  1. Q
  1. PROMPT ; Prompt user for individual Patient or Medical Foster Home (MFH) name
  1. I HBHCXREF="AJ" S DIC="^HBHC(631,",DIC("S")="I $P($G(^HBHC(631,Y,3)),U)=""Y"""
  1. I HBHCXREF="AK" S DIC="^HBHC(633.2,"
  1. S DIC(0)="AEMQZ"
  1. DIC ; Call ^DIC
  1. D ^DIC
  1. Q:(Y=-1)!($D(DTOUT))!($D(DUOUT))
  1. S HBHCTMP(+Y)="" G DIC
  1. Q
  1. PT ; Process Patient
  1. D:HBHCDIR="I" INDPT
  1. D:HBHCDIR'="I" ALLPT
  1. Q
  1. INDPT ; Process Individual Patients
  1. S HBHCI=0 F S HBHCI=$O(HBHCTMP(HBHCI)) Q:HBHCI'>0 D RATE
  1. Q
  1. ALLPT ; Process All or Active ONLY Patients
  1. 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
  1. Q
  1. MFH ; Process Medical Foster Home (MFH)
  1. D:HBHCDIR="I" INDMFH
  1. D:HBHCDIR'="I" ALLMFH
  1. Q
  1. INDMFH ; Process Individual Medical Foster Home (MFH)
  1. 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
  1. Q
  1. ALLMFH ; Process All or Active ONLY Medical Foster Homes (MFH)
  1. 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
  1. Q
  1. RATE ; Process Rate Multiple
  1. ; MFH sort => Q:Discharged patients are to be omitted
  1. I HBHCXREF="AK" I HBHCYN="N" Q:($P(^HBHC(631,HBHCI,0),U,40)]"")
  1. S HBHCCURJ="3000000" ;initialize to "00-00-00" for no date
  1. D:HBHC="A" ALLRATE
  1. D:HBHC="C" CURRATE
  1. Q
  1. ALLRATE ; Process All Rates
  1. 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
  1. Q
  1. CURRATE ; Process Current Rate Only
  1. 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
  1. S:'$D(HBHCCURK) HBHCCURK=0 D REPORT
  1. Q
  1. REPORT ; Set TMP for report format
  1. S HBHCDPT0=$G(^DPT($P(^HBHC(631,HBHCI,0),U),0))
  1. S:HBHCXREF="AJ" HBHCMFHP=$P($G(^HBHC(631,HBHCI,3)),U,2)
  1. ;HBH*1.01*33 - Add $G for ^HBHC(631 references
  1. 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
  1. S:(HBHCXREF="AK")&(HBHCDPT0]"") HBHCMFHN=$P($G(^HBHC(633.2,$S(HBHC="A":HBHCL,1:HBHCCURL),0)),U)
  1. 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)
  1. Q
  1. PRTPT ; Print loop for Patient sort
  1. 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
  1. Q
  1. CONTPT ; Cont Patient Loop
  1. 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
  1. Q
  1. PRTMFH ; Print loop for MFH sort
  1. 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
  1. Q
  1. CONTMFH ; Cont MFH Loop
  1. S HBHCJ="" F S HBHCJ=$O(^TMP("HBHC",$J,HBHCL,HBHCM,HBHCI,HBHCJ)) Q:HBHCJ="" D CONTMFH2
  1. Q
  1. CONTMFH2 ; Cont MFH Loop again...
  1. 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
  1. Q