source: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBARADM.m@ 636

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

initial load of FOIAVistA 6/30/08 version

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