- DVBADSNT ;ALB/GTS-557/THM-GENERATE AMIE NOTICE OF DISCHARGE ; 1/16/91 7:37 AM
- ;;2.7;AMIE;**1,14,17,42**;Apr 10, 1995
- N DVBGUI
- S DVBGUI=0
- K ^TMP($J) G TERM
- ;
- SET Q:'$D(^DPT(DFN,0)) D RCV^DVBAVDPT S ^TMP($J,XCN,CFLOC,MB,DFN)=XDA_U_XDA2_U_ADMDT_U_RCVAA_U_RCVPEN_U_CNUM
- Q
- ;
- ENBROKER(Y) ;
- N DVBGUI,DVBHFS,DVBERR
- S DVBGUI=1,DVBERR=0,DVBHFS=$$HFS^DVBAB82()
- K ^TMP($J) G TERM
- Q
- PRINTB S XDA=$P(DATA,U),XDA2=$P(DATA,U,2),ADMDT=$P(DATA,U,3),RCVAA=$P(DATA,U,4),RCVPEN=$P(DATA,U,5),CNUM=$P(DATA,U,6),QUIT1=1 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 D FUPD 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,! S DA=DFN D ELIG^DVBAVDPT
- FUPD K DA I XDA2]"",$P(^DVB(396,XDA2,0),U,9)="P" S DA=XDA2,DIE="^DVB(396,",DR="4.5////C;4.8////"_DT_";4.9////"_"Notice of Discharge" D ^DIE K DA
- I $D(DVBAD2) I DVBAD2=CFLOC!(CFLOC=376) S DIE="^DVB(396.2,",DA=XDA,DR="3///P;4///"_DT_";5////"_DUZ D ^DIE
- I DVBGUI=0 D
- . 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
- I DVBGUI=1 D END^DVBAB82
- Q
- PRINT1 S ADM="" F K=0:0 S ADM=$O(^TMP($J,XCN,CFLOC,ADM)) Q:ADM="" S DFN="" F L=0:0 S DFN=$O(^TMP($J,XCN,CFLOC,ADM,DFN)) Q:DFN=""!(QUIT=1) S DATA=^(DFN) D PRINTB
- Q
- ;
- TERM D HOME^%ZIS K NOASK
- D DUZ2^DVBAUTIL I $D(DVBAQUIT) K DVBAQUIT G KILL
- ;
- SETUP W @IOF,!,"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",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
- W !,HEAD1
- EN1 I DVBGUI=0 D
- . W !!,"This program will print out any new NOTICES OF DISCHARGE,",!,"based on the hospital's discharges.",!!,"Do you want to continue" S %=2 D YN^DICN
- . I $D(%Y) I %Y["?" W !!,"Enter Y to print out the notice, N if you want to exit the program.",! G EN1
- . G:%'=1 KILL S %ZIS="Q" D ^%ZIS K %ZIS I POP G KILL
- I DVBGUI=1 D HFSOPEN^DVBAB82("DVBRP",DVBHFS,"W") I DVBERR D END^DVBAB82 Q
- ;
- QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBADSNT",ZTIO=ION,NOASK=1,ZTDESC="AMIE NOTICE OF DISCHARGE REPORT" F I="FDT(0)","HEAD","HEAD1","NOASK","DVBAD2" S ZTSAVE(I)=""
- I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! K ZTSK G KILL
- ;
- GO F XDA=0:0 S XDA=$O(^DVB(396.2,"C",DVBAD2,"R",XDA)) Q:XDA="" I $D(^DVB(396.2,XDA,0)) S MB=^(0),DFN=$P(MB,U),ADMDT=$P(MB,U,2),MB=$P(MB,U,3) D CHK,SET I '$D(NOASK) W "."
- I '$D(^TMP($J)) U IO W !!,*7,"No data found.",!! H 2 G KILL
- D PRINT
- KILL D:$D(ZTQUEUED) KILL^%ZTLOAD K DVBAON2 G KILL^DVBAUTIL
- ;
- DEQUE K ^TMP($J) G GO
- ;
- CHK ;pull 7131 pointer
- F XDA2=0:0 S XDA2=$O(^DVB(396,"G",ADMDT,XDA2)) Q:XDA2="" I $D(^DVB(396,XDA2,2))&($D(^DVB(396,XDA2,0))) Q:($P(^DVB(396,XDA2,0),U,1)=DFN&($P(^DVB(396,XDA2,2),"^",10)="A"))
- Q
- ;
- REPRINT D CHK,SET,PRINT G KILL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBADSNT 4089 printed Feb 18, 2025@23:07:30 Page 2
- DVBADSNT ;ALB/GTS-557/THM-GENERATE AMIE NOTICE OF DISCHARGE ; 1/16/91 7:37 AM
- +1 ;;2.7;AMIE;**1,14,17,42**;Apr 10, 1995
- +2 NEW DVBGUI
- +3 SET DVBGUI=0
- +4 KILL ^TMP($JOB)
- GOTO TERM
- +5 ;
- SET if '$DATA(^DPT(DFN,0))
- QUIT
- DO RCV^DVBAVDPT
- SET ^TMP($JOB,XCN,CFLOC,MB,DFN)=XDA_U_XDA2_U_ADMDT_U_RCVAA_U_RCVPEN_U_CNUM
- +1 QUIT
- +2 ;
- ENBROKER(Y) ;
- +1 NEW DVBGUI,DVBHFS,DVBERR
- +2 SET DVBGUI=1
- SET DVBERR=0
- SET DVBHFS=$$HFS^DVBAB82()
- +3 KILL ^TMP($JOB)
- GOTO TERM
- +4 QUIT
- PRINTB SET XDA=$PIECE(DATA,U)
- SET XDA2=$PIECE(DATA,U,2)
- SET ADMDT=$PIECE(DATA,U,3)
- SET RCVAA=$PIECE(DATA,U,4)
- SET RCVPEN=$PIECE(DATA,U,5)
- SET CNUM=$PIECE(DATA,U,6)
- SET QUIT1=1
- 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
- DO FUPD
- 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 WRITE ?11,"Bed Service:",?26,BEDSEC,!
- SET DA=DFN
- DO ELIG^DVBAVDPT
- FUPD KILL DA
- IF XDA2]""
- IF $PIECE(^DVB(396,XDA2,0),U,9)="P"
- SET DA=XDA2
- SET DIE="^DVB(396,"
- SET DR="4.5////C;4.8////"_DT_";4.9////"_"Notice of Discharge"
- DO ^DIE
- KILL DA
- +1 IF $DATA(DVBAD2)
- IF DVBAD2=CFLOC!(CFLOC=376)
- SET DIE="^DVB(396.2,"
- SET DA=XDA
- SET DR="3///P;4///"_DT_";5////"_DUZ
- DO ^DIE
- +2 IF DVBGUI=0
- Begin DoDot:1
- +3 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
- End DoDot:1
- +4 SET DVBAON2=""
- +5 QUIT
- +6 ;
- 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 IF DVBGUI=1
- DO END^DVBAB82
- +3 QUIT
- PRINT1 SET ADM=""
- FOR K=0:0
- SET ADM=$ORDER(^TMP($JOB,XCN,CFLOC,ADM))
- if ADM=""
- QUIT
- SET DFN=""
- FOR L=0:0
- SET DFN=$ORDER(^TMP($JOB,XCN,CFLOC,ADM,DFN))
- if DFN=""!(QUIT=1)
- QUIT
- SET DATA=^(DFN)
- 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,!,"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"
- SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
- +2 WRITE !,HEAD1
- EN1 IF DVBGUI=0
- Begin DoDot:1
- +1 WRITE !!,"This program will print out any new NOTICES OF DISCHARGE,",!,"based on the hospital's discharges.",!!,"Do you want to continue"
- SET %=2
- DO YN^DICN
- +2 IF $DATA(%Y)
- IF %Y["?"
- WRITE !!,"Enter Y to print out the notice, N if you want to exit the program.",!
- GOTO EN1
- +3 if %'=1
- GOTO KILL
- SET %ZIS="Q"
- DO ^%ZIS
- KILL %ZIS
- IF POP
- GOTO KILL
- End DoDot:1
- +4 IF DVBGUI=1
- DO HFSOPEN^DVBAB82("DVBRP",DVBHFS,"W")
- IF DVBERR
- DO END^DVBAB82
- QUIT
- +5 ;
- QUEUE IF $DATA(IO("Q"))
- SET ZTRTN="DEQUE^DVBADSNT"
- SET ZTIO=ION
- SET NOASK=1
- SET ZTDESC="AMIE NOTICE OF DISCHARGE REPORT"
- FOR I="FDT(0)","HEAD","HEAD1","NOASK","DVBAD2"
- SET ZTSAVE(I)=""
- +1 IF $DATA(IO("Q"))
- DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !!,"Request queued.",!!
- KILL ZTSK
- GOTO KILL
- +2 ;
- GO FOR XDA=0:0
- SET XDA=$ORDER(^DVB(396.2,"C",DVBAD2,"R",XDA))
- if XDA=""
- QUIT
- IF $DATA(^DVB(396.2,XDA,0))
- SET MB=^(0)
- SET DFN=$PIECE(MB,U)
- SET ADMDT=$PIECE(MB,U,2)
- SET MB=$PIECE(MB,U,3)
- DO CHK
- DO SET
- IF '$DATA(NOASK)
- WRITE "."
- +1 IF '$DATA(^TMP($JOB))
- USE IO
- WRITE !!,*7,"No data found.",!!
- HANG 2
- GOTO KILL
- +2 DO PRINT
- KILL if $DATA(ZTQUEUED)
- DO KILL^%ZTLOAD
- KILL DVBAON2
- GOTO KILL^DVBAUTIL
- +1 ;
- DEQUE KILL ^TMP($JOB)
- GOTO GO
- +1 ;
- CHK ;pull 7131 pointer
- +1 FOR XDA2=0:0
- SET XDA2=$ORDER(^DVB(396,"G",ADMDT,XDA2))
- if XDA2=""
- QUIT
- IF $DATA(^DVB(396,XDA2,2))&($DATA(^DVB(396,XDA2,0)))
- if ($PIECE(^DVB(396,XDA2,0),U,1)=DFN&($PIECE(^DVB(396,XDA2,2),"^",10)="A"))
- QUIT
- +2 QUIT
- +3 ;
- REPRINT DO CHK
- DO SET
- DO PRINT
- GOTO KILL