DVBADSR1 ;ALB/GTS-557/THM-REPRINT AMIE NOTICE OF DISCHARGE ;21 JUL 89
;;2.7;AMIE;**17**;Apr 10, 1995
D HOME^%ZIS
D DUZ2^DVBAUTIL I $D(DVBAQUIT) K DVBAQUIT G EXIT
;
SETUP S HD="SINGLE NOTICE OF DISCHARGE REPRINTING"
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)
;
EN W @IOF,!?(IOM-$L(HD)\2),HD,!!
S DIC="^DVB(396.2,",DIC(0)="AEQM",DIC("A")="Enter NAME to reprint: "
S DIC("W")="S DFN=$P(^DVB(396.2,+Y,0),U,1),ADM=$P(^(0),U,3) I $D(^DGPM(+ADM,0)),$P(^(0),U,17)]"""" S DCHPTR=$P(^(0),U,17),DISCH=$S($P(^DGPM(DCHPTR,0),U,1)]"""":$P(^(0),U,1),1:"""") X DVBA(""W"")"
S DVBA("W")="W:$X>50 ! W ?($X+5),""Discharge date: "",$$FMTE^XLFDT(DISCH,""5DZ"")"
D ^DIC I X=""!(X=U) K DVBA G EXIT
I +Y<0 W *7," ??" H 1 G EN
I $P(^DVB(396.2,+Y,0),U,7)'=DVBAD2 W *7,!!,"This does not belong to your RO.",!! H 3 G EN
I +Y>0 S XDA=+Y,DA=$P(^DVB(396.2,+Y,0),U,1),ADMDT=$P(^(0),U,2),MB=$P(^(0),U,3)
S %ZIS("B")="0;P-OTHER",%ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS K %ZIS
I $D(IO("Q")) S ZTIO=ION,ZTRTN="REPRINT^DVBADSNT",ZTDESC="Reprint notice of discharge" F I="H*","D*","FDT*","A*","XDA","MB" S ZTSAVE(I)=""
I D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 2 G KILL^DVBAUTIL
I POP G KILL^DVBAUTIL
D REPRINT^DVBADSNT K ^TMP($J) G SETUP
;
EXIT G KILL^DVBAUTIL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBADSR1 1411 printed Oct 16, 2024@17:41:59 Page 2
DVBADSR1 ;ALB/GTS-557/THM-REPRINT AMIE NOTICE OF DISCHARGE ;21 JUL 89
+1 ;;2.7;AMIE;**17**;Apr 10, 1995
+2 DO HOME^%ZIS
+3 DO DUZ2^DVBAUTIL
IF $DATA(DVBAQUIT)
KILL DVBAQUIT
GOTO EXIT
+4 ;
SETUP SET HD="SINGLE NOTICE OF DISCHARGE REPRINTING"
+1 DO NOPARM^DVBAUTL2
if $DATA(DVBAQUIT)
GOTO KILL^DVBAUTIL
SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+2 SET HEAD="NOTICE OF DISCHARGE"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+3 ;
EN WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!
+1 SET DIC="^DVB(396.2,"
SET DIC(0)="AEQM"
SET DIC("A")="Enter NAME to reprint: "
+2 SET DIC("W")="S DFN=$P(^DVB(396.2,+Y,0),U,1),ADM=$P(^(0),U,3) I $D(^DGPM(+ADM,0)),$P(^(0),U,17)]"""" S DCHPTR=$P(^(0),U,17),DISCH=$S($P(^DGPM(DCHPTR,0),U,1)]"""":$P(^(0),U,1),1:"""") X DVBA(""W"")"
+3 SET DVBA("W")="W:$X>50 ! W ?($X+5),""Discharge date: "",$$FMTE^XLFDT(DISCH,""5DZ"")"
+4 DO ^DIC
IF X=""!(X=U)
KILL DVBA
GOTO EXIT
+5 IF +Y<0
WRITE *7," ??"
HANG 1
GOTO EN
+6 IF $PIECE(^DVB(396.2,+Y,0),U,7)'=DVBAD2
WRITE *7,!!,"This does not belong to your RO.",!!
HANG 3
GOTO EN
+7 IF +Y>0
SET XDA=+Y
SET DA=$PIECE(^DVB(396.2,+Y,0),U,1)
SET ADMDT=$PIECE(^(0),U,2)
SET MB=$PIECE(^(0),U,3)
+8 SET %ZIS("B")="0;P-OTHER"
SET %ZIS="AEQ"
SET %ZIS("A")="Output device: "
DO ^%ZIS
KILL %ZIS
+9 IF $DATA(IO("Q"))
SET ZTIO=ION
SET ZTRTN="REPRINT^DVBADSNT"
SET ZTDESC="Reprint notice of discharge"
FOR I="H*","D*","FDT*","A*","XDA","MB"
SET ZTSAVE(I)=""
+10 IF $TEST
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
HANG 2
GOTO KILL^DVBAUTIL
+11 IF POP
GOTO KILL^DVBAUTIL
+12 DO REPRINT^DVBADSNT
KILL ^TMP($JOB)
GOTO SETUP
+13 ;
EXIT GOTO KILL^DVBAUTIL
