source: WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBADSRP.m@ 789

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1DVBADSRP ;ALB/GTS-557/THM-REPRINT NOTICE OF DISCHARGE ; 1/22/91 12:05 PM
2 ;;2.7;AMIE;**1,17**;Apr 10, 1995
3 K ^TMP($J) G TERM
4SET Q:'$D(^DPT(DA,0)) S DFN=DA D RCV^DVBAVDPT S ^TMP($J,XCN,CFLOC,MB,DA)=ADMDT_U_RCVAA_U_RCVPEN_U_CNUM
5 Q
6 ;
7PRINTB S ADMDT=$P(DTA,U),RCVAA=$P(DTA,U,2),RCVPEN=$P(DTA,U,3),CNUM=$P(DTA,U,4),QUIT1=1,DFN=DA D ADM^DVBAVDPT
8 S LADM=ADM
9 I '$D(^DGPM(LADM,0)) S FND=1
10 I $D(^DGPM(LADM,0)) N HPAT S HPAT=$P(^DGPM(LADM,0),"^",3) I $D(^DPT(HPAT,0)) S HPAT=$P(^DPT(HPAT,0),"^") I (HPAT'=PNAM)!(ADMDT'=$P(^DGPM(LADM,0),"^")) S FND=1
11 I $D(FND) N Y S Y=ADMDT D DD^%DT W !!,"Admission entry in Patient Movement File has been deleted for: ",!,?5,PNAM,?25,SSN,?35," at ",Y,!,"Contact VAMC for further information.",! K Y,FND S DVBAON2="" Q
12 S DCHPTR=$P(^DGPM(LADM,0),U,17),TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:"") I TDIS="" S TDIS="Unknown discharge type"
13 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")
14 I DCHGDT="" S DCHGDT=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U),1:"")
15 W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
16 W !!!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
17 W ?10,"Patient Name:",?26,PNAM,!!,?14,"Claim No:",?26,CNUM,!,?6,"Claim Folder Loc:",?26,CFLOC,!,?9,"Social Sec No:",?26,SSN,!,?8,"Discharge Date:",?26,$$FMTE^XLFDT(DCHGDT,"5DZ"),!
18 W ?5,"Type of Discharge:",?26,TDIS,!
19 D LOS^DVBAUTIL W ?8,"Length of Stay:",?26,LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days"),!
20 W ?11,"Bed Service:",?26,BEDSEC,! D ELIG^DVBAVDPT ;no updating required
21 I IOST?1"C-".E W *7,!,"Press RETURN to continue or ""^"" to stop" R ANS:DTIME S:ANS=U!('$T) QUIT=1 I '$T S DVBAQUIT=1
22 S DVBAON2=""
23 Q
24 ;
25PRINT U IO S QUIT=""
26 S XCN="" F M=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUIT=1) S CFLOC="" F J=0:0 S CFLOC=$O(^TMP($J,XCN,CFLOC)) Q:CFLOC=""!(QUIT=1) D PRINT1
27 Q
28PRINT1 S ADM="" F K=0:0 S ADM=$O(^TMP($J,XCN,CFLOC,ADM)) Q:ADM=""!(QUIT=1) S DA="" F L=0:0 S DA=$O(^TMP($J,XCN,CFLOC,ADM,DA)) Q:DA=""!(QUIT=1) S DTA=^(DA) D PRINTB
29 Q
30 ;
31TERM D HOME^%ZIS K NOASK
32 D DUZ2^DVBAUTIL I $D(DVBAQUIT) K DVBAQUIT G KILL
33 ;
34SETUP W @IOF,!,"* REPRINT * NOTICE OF DISCHARGE REPORT" D NOPARM^DVBAUTL2 G:$D(DVBAQUIT) KILL^DVBAUTIL S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
35 S HEAD="NOTICE OF DISCHARGE REPRINT",U="^",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
36 W !,HEAD1
37EN1 W !!,"This program will reprint NOTICES OF DISCHARGE,",!!,"Do you want to continue" S %=2 D YN^DICN
38 I $D(%Y) I %Y["?" W !!,"Enter Y to reprint or N to quit.",! G EN1
39 I %'=1 G KILL
40ONE W !!,"Do you want only one Veteran" S %=2 D YN^DICN G:%=1 ^DVBADSR1
41 I $D(%Y) I %Y["?" W !!,"Enter Y to get one VET, N for all.",! G ONE
42 G:$D(DTOUT)!(%<0) KILL
43 ;
44ASK W ! S %DT(0)=-DT,%DT("A")="Enter ORIGINAL PROCESSING date: ",%DT="AE" D ^%DT G:Y<0 KILL S BDATE=Y K %DT
45 I X["?" W !,"The date the notices were originally printed on.",! G ASK
46 G:X=""!(X=U) KILL S %ZIS="AEQ",%ZIS("B")="0;P-OTHER" D ^%ZIS K %ZIS
47 I POP G KILL
48 ;
49QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBADSRP",ZTIO=ION,NOASK=1,ZTDESC="AMIE NOTICE OF DISCHARGE RPT" F I="REP","DVBATYPS","BDATE","FDT(0)","HEAD","HEAD1","NOASK","DVBAD2" S ZTSAVE(I)=""
50 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued." G KILL
51GO F XDA=0:0 S XDA=$O(^DVB(396.2,"C",DVBAD2,"P",XDA)) Q:XDA="" S MB=^DVB(396.2,XDA,0),DA=$P(MB,U),ADMDT=$P(MB,U,2),MB=$P(MB,U,3) D:$P(^DVB(396.2,XDA,0),U,5)=BDATE SET I '$D(NOASK) W "."
52 I '$D(^TMP($J)) U IO W !!,*7,"No data found for parameters.",!! H 2 G KILL
53 D PRINT I $D(DVBAQUIT) K DVBAON2 G KILL^DVBAUTIL
54 ;
55KILL K DVBAON2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
56 ;
57DEQUE K ^TMP($J) G GO
58 ;
59REPRINT D SET,PRINT G KILL
Note: See TracBrowser for help on using the repository browser.