DVBADSR1.m

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 ---DVBADSR1   1411     printed  Apr 09, 2024@20:59:37                                                                                                                                                                                                    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