DVBADSRP ;ALB/GTS-557/THM-REPRINT NOTICE OF DISCHARGE ; 1/22/91 12:05 PM
;;2.7;AMIE;**1,17**;Apr 10, 1995
K ^TMP($J) G TERM
SET 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
Q
;
PRINTB 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
S LADM=ADM
I '$D(^DGPM(LADM,0)) S FND=1
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
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
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"
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")
I DCHGDT="" S DCHGDT=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U),1:"")
W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
W !!!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
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"),!
W ?5,"Type of Discharge:",?26,TDIS,!
D LOS^DVBAUTIL W ?8,"Length of Stay:",?26,LOS_$S(LOS="":"Discharged same day",LOS=1:" day",1:" days"),!
W ?11,"Bed Service:",?26,BEDSEC,! D ELIG^DVBAVDPT ;no updating required
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
S DVBAON2=""
Q
;
PRINT U IO S QUIT=""
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
Q
PRINT1 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
Q
;
TERM D HOME^%ZIS K NOASK
D DUZ2^DVBAUTIL I $D(DVBAQUIT) K DVBAQUIT G KILL
;
SETUP 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")
S HEAD="NOTICE OF DISCHARGE REPRINT",U="^",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
W !,HEAD1
EN1 W !!,"This program will reprint NOTICES OF DISCHARGE,",!!,"Do you want to continue" S %=2 D YN^DICN
I $D(%Y) I %Y["?" W !!,"Enter Y to reprint or N to quit.",! G EN1
I %'=1 G KILL
ONE W !!,"Do you want only one Veteran" S %=2 D YN^DICN G:%=1 ^DVBADSR1
I $D(%Y) I %Y["?" W !!,"Enter Y to get one VET, N for all.",! G ONE
G:$D(DTOUT)!(%<0) KILL
;
ASK W ! S %DT(0)=-DT,%DT("A")="Enter ORIGINAL PROCESSING date: ",%DT="AE" D ^%DT G:Y<0 KILL S BDATE=Y K %DT
I X["?" W !,"The date the notices were originally printed on.",! G ASK
G:X=""!(X=U) KILL S %ZIS="AEQ",%ZIS("B")="0;P-OTHER" D ^%ZIS K %ZIS
I POP G KILL
;
QUEUE 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)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued." G KILL
GO 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 "."
I '$D(^TMP($J)) U IO W !!,*7,"No data found for parameters.",!! H 2 G KILL
D PRINT I $D(DVBAQUIT) K DVBAON2 G KILL^DVBAUTIL
;
KILL K DVBAON2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBAUTIL
;
DEQUE K ^TMP($J) G GO
;
REPRINT D SET,PRINT G KILL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBADSRP 3743 printed Oct 16, 2024@17:42 Page 2
DVBADSRP ;ALB/GTS-557/THM-REPRINT NOTICE OF DISCHARGE ; 1/22/91 12:05 PM
+1 ;;2.7;AMIE;**1,17**;Apr 10, 1995
+2 KILL ^TMP($JOB)
GOTO TERM
SET if '$DATA(^DPT(DA,0))
QUIT
SET DFN=DA
DO RCV^DVBAVDPT
SET ^TMP($JOB,XCN,CFLOC,MB,DA)=ADMDT_U_RCVAA_U_RCVPEN_U_CNUM
+1 QUIT
+2 ;
PRINTB SET ADMDT=$PIECE(DTA,U)
SET RCVAA=$PIECE(DTA,U,2)
SET RCVPEN=$PIECE(DTA,U,3)
SET CNUM=$PIECE(DTA,U,4)
SET QUIT1=1
SET DFN=DA
DO ADM^DVBAVDPT
+1 SET LADM=ADM
+2 IF '$DATA(^DGPM(LADM,0))
SET FND=1
+3 IF $DATA(^DGPM(LADM,0))
NEW HPAT
SET HPAT=$PIECE(^DGPM(LADM,0),"^",3)
IF $DATA(^DPT(HPAT,0))
SET HPAT=$PIECE(^DPT(HPAT,0),"^")
IF (HPAT'=PNAM)!(ADMDT'=$PIECE(^DGPM(LADM,0),"^"))
SET FND=1
+4 IF $DATA(FND)
NEW Y
SET Y=ADMDT
DO DD^%DT
WRITE !!,"Admission entry in Patient Movement File has been deleted for: ",!,?5,PNAM,?25,SSN,?35," at ",Y,!,"Contact VAMC for further information.",!
KILL Y,FND
SET DVBAON2=""
QUIT
+5 SET DCHPTR=$PIECE(^DGPM(LADM,0),U,17)
SET TDIS=$SELECT($DATA(^DGPM(+DCHPTR,0)):$PIECE(^(0),U,18),1:"")
IF TDIS=""
SET TDIS="Unknown discharge type"
+6 if '$DATA(^DG(405.2,+TDIS,0))
SET TDIS="Unknown discharge type"
IF $DATA(^(0))
SET TDIS=$SELECT($PIECE(^DG(405.2,+TDIS,0),U,1)]"":$PIECE(^(0),U,1),1:"Unknown discharge type")
+7 IF DCHGDT=""
SET DCHGDT=$SELECT($DATA(^DGPM(+DCHPTR,0)):$PIECE(^(0),U),1:"")
+8 if (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+9 WRITE !!!!,?(80-$LENGTH(HEAD)\2),HEAD,!,?(80-$LENGTH(HEAD1)\2),HEAD1,!!
+10 WRITE ?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"),!
+11 WRITE ?5,"Type of Discharge:",?26,TDIS,!
+12 DO LOS^DVBAUTIL
WRITE ?8,"Length of Stay:",?26,LOS_$SELECT(LOS="":"Discharged same day",LOS=1:" day",1:" days"),!
+13 ;no updating required
WRITE ?11,"Bed Service:",?26,BEDSEC,!
DO ELIG^DVBAVDPT
+14 IF IOST?1"C-".E
WRITE *7,!,"Press RETURN to continue or ""^"" to stop"
READ ANS:DTIME
if ANS=U!('$TEST)
SET QUIT=1
IF '$TEST
SET DVBAQUIT=1
+15 SET DVBAON2=""
+16 QUIT
+17 ;
PRINT USE IO
SET QUIT=""
+1 SET XCN=""
FOR M=0:0
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""!(QUIT=1)
QUIT
SET CFLOC=""
FOR J=0:0
SET CFLOC=$ORDER(^TMP($JOB,XCN,CFLOC))
if CFLOC=""!(QUIT=1)
QUIT
DO PRINT1
+2 QUIT
PRINT1 SET ADM=""
FOR K=0:0
SET ADM=$ORDER(^TMP($JOB,XCN,CFLOC,ADM))
if ADM=""!(QUIT=1)
QUIT
SET DA=""
FOR L=0:0
SET DA=$ORDER(^TMP($JOB,XCN,CFLOC,ADM,DA))
if DA=""!(QUIT=1)
QUIT
SET DTA=^(DA)
DO PRINTB
+1 QUIT
+2 ;
TERM DO HOME^%ZIS
KILL NOASK
+1 DO DUZ2^DVBAUTIL
IF $DATA(DVBAQUIT)
KILL DVBAQUIT
GOTO KILL
+2 ;
SETUP WRITE @IOF,!,"* REPRINT * NOTICE OF DISCHARGE REPORT"
DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+1 SET HEAD="NOTICE OF DISCHARGE REPRINT"
SET U="^"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+2 WRITE !,HEAD1
EN1 WRITE !!,"This program will reprint NOTICES OF DISCHARGE,",!!,"Do you want to continue"
SET %=2
DO YN^DICN
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to reprint or N to quit.",!
GOTO EN1
+2 IF %'=1
GOTO KILL
ONE WRITE !!,"Do you want only one Veteran"
SET %=2
DO YN^DICN
if %=1
GOTO ^DVBADSR1
+1 IF $DATA(%Y)
IF %Y["?"
WRITE !!,"Enter Y to get one VET, N for all.",!
GOTO ONE
+2 if $DATA(DTOUT)!(%<0)
GOTO KILL
+3 ;
ASK WRITE !
SET %DT(0)=-DT
SET %DT("A")="Enter ORIGINAL PROCESSING date: "
SET %DT="AE"
DO ^%DT
if Y<0
GOTO KILL
SET BDATE=Y
KILL %DT
+1 IF X["?"
WRITE !,"The date the notices were originally printed on.",!
GOTO ASK
+2 if X=""!(X=U)
GOTO KILL
SET %ZIS="AEQ"
SET %ZIS("B")="0;P-OTHER"
DO ^%ZIS
KILL %ZIS
+3 IF POP
GOTO KILL
+4 ;
QUEUE IF $DATA(IO("Q"))
SET ZTRTN="DEQUE^DVBADSRP"
SET ZTIO=ION
SET NOASK=1
SET ZTDESC="AMIE NOTICE OF DISCHARGE RPT"
FOR I="REP","DVBATYPS","BDATE","FDT(0)","HEAD","HEAD1","NOASK","DVBAD2"
SET ZTSAVE(I)=""
+1 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued."
GOTO KILL
GO FOR XDA=0:0
SET XDA=$ORDER(^DVB(396.2,"C",DVBAD2,"P",XDA))
if XDA=""
QUIT
SET MB=^DVB(396.2,XDA,0)
SET DA=$PIECE(MB,U)
SET ADMDT=$PIECE(MB,U,2)
SET MB=$PIECE(MB,U,3)
if $PIECE(^DVB(396.2,XDA,0),U,5)=BDATE
DO SET
IF '$DATA(NOASK)
WRITE "."
+1 IF '$DATA(^TMP($JOB))
USE IO
WRITE !!,*7,"No data found for parameters.",!!
HANG 2
GOTO KILL
+2 DO PRINT
IF $DATA(DVBAQUIT)
KILL DVBAON2
GOTO KILL^DVBAUTIL
+3 ;
KILL KILL DVBAON2
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBAUTIL
+1 ;
DEQUE KILL ^TMP($JOB)
GOTO GO
+1 ;
REPRINT DO SET
DO PRINT
GOTO KILL
