Routine: DVBADSRP

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

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=""

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

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

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  Apr 23, 2025@17:55:35                                                                                                                                                                                                    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

DVBADSRP.m