source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBAB56.m@ 1259

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1DVBAB56 ;ALB/SPH - CAPRI READMISSION REPORT ;09/05/00
2 ;;2.7;AMIE;**35**;Apr 10, 1995
3 ;
4STRT(ZMSG,BDATE,EDATE,DVBAH) ;
5 S DVBABCNT=0
6 G TERM
7SORT D RCV^DVBAVDPT I $D(RONUM),$D(RO) Q:CFLOC'=RONUM&(RO="Y")
8 I RCVAA S ^TMP("DVBA",$J,"A&A",DFN)=""
9 I RCVPEN S ^TMP("DVBA",$J,"PEN",DFN)=""
10 Q
11 ;
12DCHGDT S (LADMDT,LDCHGDT)="",DCHPTR=$P(^DGPM(VY,0),U,17),LADMDT=$P(^(0),U,1) I DCHPTR]"",$D(^DGPM(+DCHPTR,0)) S LDCHGDT=$P(^DGPM(+DCHPTR,0),U,1)
13 Q
14 ;
15CAL S I="",ZI=1 F DVBAI=0:0 S I=$O(^DGPM("APID",DFN,I)) Q:I="" F J=0:0 S J=$O(^DGPM("APID",DFN,I,J)) Q:J="" S ZJ=$S($D(^DGPM(J,0)):^(0),1:"") I $P(ZJ,U,1)'>EDATE,$P(ZJ,U,2)=1 S ^TMP("DVBA",$J,"ADM",DFN,ZI,J)="",ZI=ZI+1
16 S VX=$O(^TMP("DVBA",$J,"ADM",DFN,1,0)) Q:VX="" S CURADMDT=$P(^DGPM(VX,0),U,1) Q:CURADMDT=""
17 F VX=1:1 S VX=$O(^TMP("DVBA",$J,"ADM",DFN,VX)) Q:VX="" F VY=0:0 S VY=$O(^TMP("DVBA",$J,"ADM",DFN,VX,VY)) Q:VY="" D DCHGDT I CURADMDT["."&(LADMDT[".") D SET
18 Q
19TDIS S TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:"") Q:TDIS=""
20 S:'$D(^DG(405.2,+TDIS,0)) TDIS="Unknown discharge type" I $D(^(0)) S TDIS=$S($P(^DG(405.2,+TDIS,0),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
21 Q
22 ;
23SET S X1=CURADMDT,X2=LDCHGDT D ^%DTC Q:X>185
24 S X2=LADMDT,X1=LDCHGDT D ^%DTC S LOS=X Q:LOS'>HOSPDAYS
25 I DVBAT="A&A" DO ;**Check last admission for A&A vet
26 .S ADMDT=LADMDT
27 .D ADM^DVBAVDPT,TDIS
28 .I TDIS["IRREGULAR" DO ;**Irregular discharge, set last admis info
29 ..S ^TMP("DVBA",DVBAT,$J,XCN,CFLOC,VY,DFN,"LADM")=LADMDT_U_TDIS
30 I $D(TDIS),(TDIS'["IRREGULAR"&(DVBAT="A&A")) Q ;**Quit
31 S ADMDT=CURADMDT
32 D ADM^DVBAVDPT,TDIS
33 ;**Set current admis info
34 S ^TMP("DVBA",DVBAT,$J,XCN,CFLOC,VY,DFN)=CURADMDT_U_RCVAA_U_RCVPEN_U_CNUM_U_TDIS
35 I DVBAT="PEN" DO ;**Set last admis info for Pension vet
36 .S ADMDT=LADMDT
37 .D ADM^DVBAVDPT,TDIS
38 .S ^TMP("DVBA",DVBAT,$J,XCN,CFLOC,VY,DFN,"LADM")=LADMDT_U_TDIS
39 K DVBARADQ
40 S (VX,VY)=9999999
41 Q
42 ;
43TERM ;D HOME^%ZIS
44 K ^TMP("DVBA",$J),^TMP("DVBA","PEN",$J),^TMP("DVBA","A&A",$J),NOASK
45 ;D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL
46 ;
47SETUP ;W @IOF,!,"VARO RE-ADMISSION REPORT"
48 S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
49 S HEAD="RE-ADMISSION REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
50 ;W !,HEAD1
51EN1 ;W !!,"Please enter admission dates for search, oldest date first,",!,"most recent date last.",!!,"Last report was run on " S Y=$P(DTAR,U,7) X ^DD("DD") W Y,!!
52 ;D DATE^DVBAUTIL G:Y<0 KILL^DVBAUTIL
53 S BDATE1=BDATE+.5,HEADDT="Date range: "_$$FMTE^XLFDT(BDATE1,"5DZ")_" to "_$$FMTE^XLFDT(EDATE,"5DZ")
54 ;
55ASK ;W !!,"Do you want (H)ospital or Hospital-(D)om H// " R DVBAH:DTIME G:'$T!(DVBAH=U) KILL^DVBAUTIL
56 I DVBAH="" S DVBAH="H" W DVBAH
57 S:DVBAH="d" DVBAH="D"
58 S:DVBAH="h" DVBAH="H"
59 I DVBAH'?1"H"&(DVBAH'?1"D") W *7,!!,"Must be H for HOSPITAL or D for HOSPITAL-DOM",!! H 3 G ASK
60 S HEAD=HEAD_" ("_$S(DVBAH="H":"Hospital",DVBAH="D":"Hospital-Dom",1:"Unknown selection")_")"
61 S Z=$S(DVBAH="D":1,DVBAH="H":2,1:0) W $P("om^ospital",U,Z),!!
62 ;S %ZIS("B")="0;P-OTHER",%ZIS("A")="Printing device: ",%ZIS="AEQ" D ^%ZIS G:POP KILL^DVBAUTIL
63 I $D(IO("Q")) F I="NOASK","HEAD*","FDT(0)","DTAR","BDATE*","EDATE*","DVBAH" S ZTSAVE(I)=""
64 I S NOASK=1,ZTRTN="DQ^DVBARADM",ZTDESC="AMIE Re-admission Report",ZTIO=ION D ^%ZTLOAD W:$D(ZTSK) !,"Request queued.",!! G KILL^DVBAUTIL
65GO I '$D(NOASK) W !!,"Looking for Pension and A&A cases ...",!!
66 F DVBADT=BDATE:0 S DVBADT=$O(^DGPM("AMV1",DVBADT)) Q:DVBADT=""!(DVBADT>EDATE) W:'$D(NOASK) "." F DFN=0:0 S DFN=$O(^DGPM("AMV1",DVBADT,DFN)) Q:DFN="" F ADM=0:0 S ADM=$O(^DGPM("AMV1",DVBADT,DFN,ADM)) Q:ADM="" D SORT
67 I '$D(NOASK) W !!,"Examining cases found for re-admissions within 185 days ...",!!
68 F DVBAT="PEN","A&A" S HOSPDAYS=$S(DVBAT="PEN"&(DVBAH="H"):89,DVBAT="PEN"&(DVBAH="D"):59,1:29) F DFN=0:0 S DFN=$O(^TMP("DVBA",$J,DVBAT,DFN)) Q:DFN="" D CAL W:'$D(NOASK) "+"
69 K ^TMP("DVBA",$J,"PEN"),^TMP("DVBA",$J,"A&A")
70 I '$D(^TMP("DVBA","PEN",$J))&('$D(^TMP("DVBA","A&A",$J))) W "No data found for parameters entered." H 2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
71 G ^DVBAB98
72 ;
73DQ K ^TMP("DVBA",$J),^TMP("DVBA","PEN",$J),^TMP("DVBA","A&A",$J)
74 G GO
Note: See TracBrowser for help on using the repository browser.