source: WorldVistAEHR/trunk/r/HOSPITAL_BASED_HOME_CARE-HBH/HBHCRP7.m@ 701

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1HBHCRP7 ; LR VAMC(IRMS)/MJT-HBHC file 631 rpt, user selects: adm or D/C by date range, & sort alphabetic by pt or date of adm or D/C; includes adm/D/C date, pt name, last four, & primary DX @ adm/D/C (code & text); ; 12/21/05 3:43pm
2 ;;1.0;HOSPITAL BASED HOME CARE;**5,6,21,22**;NOV 01, 1993;Build 2
3 S DIR(0)="SB^A:Admissions;D:Discharges;",DIR("A")="Select Admissions or Discharges",DIR("?")="Enter 'A' to include Admissions on the report, 'D' to choose Discharges." D ^DIR
4 G:$D(DIRUT) EXIT
5 S HBHCTYPS=Y(0),HBHCTYP=$E(Y(0),1,9),HBHCXREF=$S(Y="A":"AD",1:"AC"),HBHCDXPC=$S(Y="A":19,1:47),HBHCCC=0
6 ; Prompt user for sort preference: alphabetical by patient or date of admission or D/C
7 K DIR S DIR(0)="SB^A:Alphabetical;D:Date of Admission or D/C",DIR("A")="Sort Alphabetically by Patient or by Date",DIR("?")="Sort report alphabetically by patient (A), or by date of admission or D/C (D)." D ^DIR
8 G:$D(DIRUT) EXIT
9 ; HBHCFLG exists if alphabetic sort selected
10 S:Y="A" HBHCFLG=1
11 D START^HBHCUTL
12 G:(HBHCBEG1=-1)!(HBHCEND1=-1) EXIT
13 S %ZIS="Q" K IOP,ZTIO,ZTSAVE D ^%ZIS G:POP EXIT
14 I $D(IO("Q")) S ZTRTN="DQ^HBHCRP7",ZTDESC="HBPC "_HBHCTYP_"Alphabetic Date Range Report",ZTSAVE("HBHC*")="" D ^%ZTLOAD G EXIT
15DQ ; De-queue
16 U IO
17 K ^TMP("HBHC",$J)
18 S $P(HBHCY,"-",133)="",$P(HBHCZ,"=",133)=""
19 S:'$D(HBHCFLG) HBHCHEAD=HBHCTYPS_" by Date Range, Date Range Sort"
20 S:$D(HBHCFLG) HBHCHEAD=HBHCTYPS_" by Date Range, Alphabetic Sort"
21 S:'$D(HBHCFLG) HBHCHDR="W HBHCTYP_"" Date"",?19,""Patient Name"",?60,""Last Four"",?82,""ICD9 Code"",?100,""Diagnosis Text"""
22 S:$D(HBHCFLG) HBHCHDR="W ""Patient Name"",?38,HBHCTYP_"" Date"",?60,""Last Four"",?82,""ICD9 Code"",?100,""Diagnosis Text"""
23 S HBHCCOLM=(132-(30+$L(HBHCHEAD))\2) S:HBHCCOLM'>0 HBHCCOLM=1
24 D TODAY^HBHCUTL
25LOOP ; Loop thru ^HBHC(631) "AD" (admission date) or "AC" (discharge date) cross-ref to build report
26 S X1=HBHCBEG1,X2=-1 D C^%DTC S HBHCDATE=X
27 F S HBHCDATE=$O(^HBHC(631,HBHCXREF,HBHCDATE)) Q:(HBHCDATE="")!(HBHCDATE>HBHCEND1) S HBHCDFN="" F S HBHCDFN=$O(^HBHC(631,HBHCXREF,HBHCDATE,HBHCDFN)) Q:HBHCDFN="" S HBHCNOD0=^HBHC(631,HBHCDFN,0) D:$P(HBHCNOD0,U,15)=1 PROCESS
28 D:IO'=IO(0)!($D(IO("S"))) HDR132^HBHCUTL
29 I '$D(IO("S")),(IO=IO(0)) S HBHCCC=HBHCCC+1 D HDR132^HBHCUTL
30 W:'$D(^TMP("HBHC",$J)) !!,"No "_HBHCTYPS_" found for Date Range selected."
31 I $D(^TMP("HBHC",$J)) D PRTLOOP W !!,HBHCZ,!,"Total "_HBHCTYPS_": ",HBHCTOT,!,HBHCZ
32 D END132^HBHCUTL1
33EXIT ; Exit module
34 D ^%ZISC
35 K DIR,DIRUT,HBHCBEG1,HBHCBEG2,HBHCCOLM,HBHCCC,HBHCDATE,HBHCDFN,HBHCDPT0,HBHCDT,HBHCDXPC,HBHCEND1,HBHCEND2,HBHCFLG,HBHCHDR,HBHCHEAD,HBHCICD0,HBHCNAME,HBHCNOD0,HBHCPAGE,HBHCTDY,HBHCTMP,HBHCTOT,HBHCTYP,HBHCTYPS,HBHCXREF,HBHCY,HBHCZ
36 K X,X1,X2,Y,^TMP("HBHC",$J)
37 Q
38PROCESS ; Process record & create ^TMP("HBHC",$J global
39 S HBHCDPT0=^DPT($P(HBHCNOD0,U),0),HBHCICD0=$S($P(HBHCNOD0,U,HBHCDXPC)]"":^ICD9($P(HBHCNOD0,U,HBHCDXPC),0),1:"")
40 S:'$D(HBHCFLG) ^TMP("HBHC",$J,HBHCDATE,$P(HBHCDPT0,U))=$E($P(HBHCDPT0,U,9),6,9)_U_$P(HBHCICD0,U)_U_$P(HBHCICD0,U,3)
41 S:$D(HBHCFLG) ^TMP("HBHC",$J,$P(HBHCDPT0,U),HBHCDATE)=$E($P(HBHCDPT0,U,9),6,9)_U_$P(HBHCICD0,U)_U_$P(HBHCICD0,U,3)
42 Q
43PRTLOOP ; Print loop
44 S HBHCTOT=0
45 I '$D(HBHCFLG) S HBHCDT="" F S HBHCDT=$O(^TMP("HBHC",$J,HBHCDT)) Q:HBHCDT="" S HBHCNAME="" F S HBHCNAME=$O(^TMP("HBHC",$J,HBHCDT,HBHCNAME)) Q:HBHCNAME="" D PRT
46 I $D(HBHCFLG) S HBHCNAME="" F S HBHCNAME=$O(^TMP("HBHC",$J,HBHCNAME)) Q:HBHCNAME="" S HBHCDT="" F S HBHCDT=$O(^TMP("HBHC",$J,HBHCNAME,HBHCDT)) Q:HBHCDT="" D PRT
47 Q
48PRT ; Print report
49 I ($D(ZTRTN)!(HBHCCC=0))&((IOSL-$Y)<5) W @IOF D HDR132^HBHCUTL
50 S HBHCTOT=HBHCTOT+1
51 S:'$D(HBHCFLG) HBHCTMP=^TMP("HBHC",$J,HBHCDT,HBHCNAME)
52 S:$D(HBHCFLG) HBHCTMP=^TMP("HBHC",$J,HBHCNAME,HBHCDT)
53 W:'$D(HBHCFLG) !,$E(HBHCDT,4,5)_"-"_$E(HBHCDT,6,7)_"-"_$E(HBHCDT,2,3),?19,HBHCNAME,?60,$P(HBHCTMP,U),?82,$P(HBHCTMP,U,2),?100,$P(HBHCTMP,U,3),!,HBHCY
54 W:$D(HBHCFLG) !,HBHCNAME,?38,$E(HBHCDT,4,5)_"-"_$E(HBHCDT,6,7)_"-"_$E(HBHCDT,2,3),?60,$P(HBHCTMP,U),?82,$P(HBHCTMP,U,2),?100,$P(HBHCTMP,U,3),!,HBHCY
55 Q
Note: See TracBrowser for help on using the repository browser.