- 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 Mar 13, 2025@20:45:47 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
