source: FOIAVistA/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCUTL2.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1HBHCUTL2 ; LR VAMC(IRMS)/MJT-HBHC Utility module, Entry points: PROV, EN, EN2, TOT, & FTOT (see line labels for called by routines) ; Aug 2000
2 ;;1.0;HOSPITAL BASED HOME CARE;**6,16,14,22**;NOV 01, 1993;Build 2
3PROV ; Provider variable setup, called by ^HBHCRP4, ^HBHCRP9, ^HBHCRP22
4 S HBHCWHO="provider",HBHCWHOS="providers",HBHCWHOC="Provider"
5 Q
6EN ; Entry point called by ^HBHCRP4, ^HBHCRP6, ^HBHCRP9, & ^HBHCRP22
7 S HBHCCC=0
8 W !!,"Do you wish to include ALL ",HBHCWHOS," on the report" S %=1 D YN^DICN
9 W !
10 I %=0 W !!,"A 'Yes' response will include ALL "_HBHCWHOS_". A 'No' response will",!,"prompt for an individual "_HBHCWHO_" name." G EN
11 I %=2 K DIC S DIC="^HBHC(631.4,",DIC(0)="AEMQ",DIC("A")="Select HBPC "_HBHCWHOC_": ",DIC("S")="I $P(^HBHC(631.4,Y,0),U,7)="""""
12ENPRV ; Enter provider prompt
13 I %=2 D ^DIC S:+Y>0 HBHCPRVL(+Y)="" G:Y>0 ENPRV
14 Q
15EN2 ; Entry point 2 called by ^HBHCRP6 & ^HBHCRP9
16 D START^HBHCUTL
17 G:(HBHCBEG1=-1)!(HBHCEND1=-1) EXIT
18 S %ZIS="Q" K IOP,ZTIO,ZTSAVE D ^%ZIS G:POP EXIT
19 I $D(IO("Q")) S ZTRTN="DQ^HBHCUTL2",ZTDESC="HBPC "_HBHCWHOC_" Census Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT
20DQ ; De-queue
21 U IO
22 K ^TMP("HBHC",$J)
23 S $P(HBHCY,"-",133)="",$P(HBHCZ,"=",133)="",HBHCTXT="Case Census",HBHCHEAD=HBHCWHOC_" Census",HBHCHDR="W !,""Patient Name"",?28,""Last Four"",?41,""Date"",?51,""Street Address"",?83,""City"",?100,""ZIP Code"",?112,""Phone"""
24 S HBHCCOLM=(132-(30+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1 S (HBHCTOT,HBHCFTOT)=0
25 D TODAY^HBHCUTL
26LOOP ; Loop thru ^HBHC(631) "AD" (Admission Date) cross-ref to build report for case manager report or thru ^HBHC(632) "C" (Visit Date) for provider report
27 S X1=HBHCBEG1,X2=-1 D C^%DTC S HBHCDATE=X
28 F S HBHCDATE=$O(^HBHC(HBHCFILE,HBHCXREF,HBHCDATE)) Q:(HBHCDATE="")!(HBHCDATE>HBHCEND1) S HBHCDFN="" F S HBHCDFN=$O(^HBHC(HBHCFILE,HBHCXREF,HBHCDATE,HBHCDFN)) Q:HBHCDFN="" D PROCESS
29 I '$D(^TMP("HBHC",$J)) K HBHCNAM D HDR132^HBHCUTL W !!,"No data found for "_HBHCWHOC_" by Date Range selected."
30 I $D(^TMP("HBHC",$J)) D PRTLOOP D:'$D(HBHCPRVL) FTOT
31 D END132^HBHCUTL1
32EXIT ; Exit module
33 D ^%ZISC
34 K DIC,DTOUT,DUOUT,HBHCADDT,HBHCBEG1,HBHCBEG2,HBHCC,HBHCCC,HBHCCLM1,HBHCCOLM,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCDPTA,HBHCEND1,HBHCEND2,HBHCFILE,HBHCFTOT,HBHCHDR,HBHCHEAD,HBHCLST4,HBHCNAM,HBHCNBR,HBHCNDX,HBHCNM,HBHCNOD0,HBHCNOD1
35 K HBHCPAGE,HBHCPHON,HBHCPRV,HBHCPRVL,HBHCTDY,HBHCTMP,HBHCTOT,HBHCTXT,HBHCWHO,HBHCWHOC,HBHCWHOS,HBHCXREF,HBHCY,HBHCZ,HBHCZIP,X,Y,^TMP("HBHC",$J),%
36 Q
37PROCESS ; Process record & create ^TMP("HBHC",$J global
38 S HBHCNOD0=^HBHC(HBHCFILE,HBHCDFN,0),HBHCNOD1=$G(^HBHC(HBHCFILE,HBHCDFN,1))
39 ; Q if no case manager or not selected case manager
40 I HBHCFILE=631 Q:$P(HBHCNOD1,U,13)="" Q:($D(HBHCPRVL))&('$D(HBHCPRVL($P(HBHCNOD1,U,13))))
41 I HBHCFILE=631 Q:(($P(HBHCNOD0,U,40)]"")&($P(HBHCNOD0,U,40)<HBHCEND1))!($P(HBHCNOD0,U,15)=2)!($P(HBHCNOD1,U,13)="") S HBHCADDT=$E(HBHCDATE,4,5)_"-"_$E(HBHCDATE,6,7)_"-"_$E(HBHCDATE,2,3)
42 I HBHCFILE=632 Q:$P(HBHCNOD0,U,4)="" Q:($D(HBHCPRVL))&('$D(HBHCPRVL($P(HBHCNOD0,U,4)))) ; Q if not selected provider
43 I HBHCFILE=632 S (HBHCNBR,HBHCNDX)="" F S HBHCNBR=$O(^HBHC(631,"B",+HBHCNOD0,HBHCNBR)) Q:HBHCNBR="" S HBHCNDX=HBHCNBR
44 I HBHCFILE=632 Q:HBHCNDX="" Q:(($P(^HBHC(631,HBHCNDX,0),U,40)]"")&($P(^HBHC(631,HBHCNDX,0),U,40)<HBHCEND1))!($P(^HBHC(631,HBHCNDX,0),U,15)=2)
45 I HBHCFILE=632 S HBHCADDT=$P(^HBHC(631,HBHCNDX,0),U,18),HBHCADDT=$E(HBHCADDT,4,5)_"-"_$E(HBHCADDT,6,7)_"-"_$E(HBHCADDT,2,3) Q:$P(HBHCNOD0,U,4)=""
46 S HBHCNAM=$S(HBHCFILE=631:$P(^VA(200,$P(^HBHC(631.4,$P(HBHCNOD1,U,13),0),U,2),0),U)_" ("_$P(^HBHC(631.4,$P(HBHCNOD1,U,13),0),U)_")",1:$P(^VA(200,$P(^HBHC(631.4,$P(HBHCNOD0,U,4),0),U,2),0),U)_" ("_$P(^HBHC(631.4,$P(HBHCNOD0,U,4),0),U)_")")
47 S HBHCDPT0=^DPT($P(HBHCNOD0,U),0),HBHCDPTA=$G(^DPT($P(HBHCNOD0,U),.11))
48 S HBHCLST4=$E($P(HBHCDPT0,U,9),6,9),HBHCNM=$E($P(HBHCDPT0,U),1,26)
49 S HBHCZIP=$S(($P(HBHCDPTA,U,12)]""):$E($P(HBHCDPTA,U,12),1,5)_$S($E($P(HBHCDPTA,U,12),6,9)]"":"-"_$E($P(HBHCDPTA,U,12),6,9),1:""),1:$E($P(HBHCDPTA,U,6),1,5)_$S($E($P(HBHCDPTA,U,6),6,9)]"":"-"_$E($P(HBHCDPTA,U,6),6,9),1:""))
50 S HBHCPHON=$P($G(^DPT($P(HBHCNOD0,U),.13)),U) S:HBHCPHON?7N HBHCPHON=$E(HBHCPHON,1,3)_"-"_$E(HBHCPHON,4,7) S:HBHCPHON?10N HBHCPHON="("_$E(HBHCPHON,1,3)_") "_$E(HBHCPHON,4,6)_"-"_$E(HBHCPHON,7,10)
51 S ^TMP("HBHC",$J,HBHCNAM,HBHCNM)=HBHCLST4_U_HBHCADDT_U_$P(HBHCDPTA,U)_U_$P(HBHCDPTA,U,2)_U_$P(HBHCDPTA,U,3)_U_$E($P(HBHCDPTA,U,4),1,15)_U_HBHCZIP_U_HBHCPHON
52 Q
53PRTLOOP ; Print loop
54 S HBHCPRV="" F S HBHCPRV=$O(^TMP("HBHC",$J,HBHCPRV)) D:HBHCTOT>0 TOT Q:HBHCPRV="" D HDR S HBHCNM="" F S HBHCNM=$O(^TMP("HBHC",$J,HBHCPRV,HBHCNM)) Q:HBHCNM="" D PRT
55 Q
56HDR ; Report header setup
57 S HBHCPAGE=0,HBHCNAM=HBHCPRV,HBHCCLM1=(132-(HBHCC+$L(HBHCNAM))\2) S:HBHCCLM1'>0 HBHCCLM1=1
58 W @IOF D HDR132^HBHCUTL
59 Q
60PRT ; Print report
61 I ($D(ZTRTN)!(HBHCCC=0))&((IOSL-$Y)<5) W @IOF D HDR132^HBHCUTL
62 S HBHCTOT=HBHCTOT+1,HBHCTMP=^TMP("HBHC",$J,HBHCPRV,HBHCNM)
63 W !,HBHCNM,?28,$P(HBHCTMP,U),?41,$P(HBHCTMP,U,2),?51,$P(HBHCTMP,U,3),?83,$P(HBHCTMP,U,6),?100,$P(HBHCTMP,U,7),?112,$P(HBHCTMP,U,8)
64 W:$P(HBHCTMP,U,4)]"" !?51,$P(HBHCTMP,U,4)
65 W:$P(HBHCTMP,U,5)]"" !?51,$P(HBHCTMP,U,5)
66 W !,HBHCY
67 Q
68TOT ; Print case manager/provider total, called by ^HBHCRP4 & ^HBHCRP22
69 W !!,HBHCZ,!,HBHCWHOC_": "_HBHCNAM_" "_HBHCTXT_" Total: ",HBHCTOT,!,HBHCZ
70 S HBHCFTOT=HBHCFTOT+HBHCTOT,HBHCTOT=0
71 Q
72FTOT ; Print report final total, called by ^HBHCRP4 & ^HBHCRP22
73 K HBHCHDR,HBHCNAM S HBHCPAGE=0 W @IOF
74 ; for HBHCUTL2 calls (called from HBHCRP6 & HBHCRP9)
75 D:$L(HBHCZ)=132 HDR132^HBHCUTL
76 ; for HBHCRP4 & HBHCRP22 calls
77 D:$L(HBHCZ)=80 HDRRANGE^HBHCUTL
78 W !!,HBHCTXT_" Total: ",HBHCFTOT,!!,HBHCZ
79 Q
Note: See TracBrowser for help on using the repository browser.