DVBCRPON.m

DVBCRPON ;ALB/GTS-557/THM-REPRINT C&P REPORTS ; 7/1/91  1:09 PM

 ;;2.7;AMIE;**2,32,193**;Apr 10, 1995;Build 84

 ;

SETUP D HOME^%ZIS K ULINE S FF=IOF,HD="Reprint C & P Exams"

 S XDD=^DD("DD"),$P(ULINE,"_",70)="_"

 I $G(DUZ(2))<1 W !!,*7,"Your division code is invalid.",!! H 2 G EXIT

 S SUPER=0 I $D(^XUSEC("DVBA C SUPERVISOR",DUZ)) S SUPER=1

 ;

SETUP1 ;** Drops into if setup is ok

 W @IOF,!?(IOM-$L(HD)\2),HD,!!!

 S ONE="N",Y=DT X XDD

 S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",LOC=DUZ(2),PG=0,DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")

 ;

RASK W !!,"Select Reprint Option - (D)ate or (V)eteran:  D// " R RTYPE:DTIME I RTYPE[U!('$T) G EXIT

 I RTYPE'=""&(RTYPE'="D"&(RTYPE'="d"&(RTYPE'="v"&(RTYPE'="V")))) S RTYPE="E"

 W:RTYPE="" "Date" W $S(RTYPE="D"!(RTYPE="d"):"ate",RTYPE="V"!(RTYPE="v"):"eteran",1:"") I RTYPE=""!(RTYPE="d") S RTYPE="D"

 I RTYPE="v" S RTYPE="V"

 I RTYPE'?1"D",RTYPE'?1"V" W !!,"Must be D or V" G RASK

 G:RTYPE="D" ADATE I RTYPE="V" S ONE="Y"

 ;

ONLYLAB ;** Dropped into if the user doesn't exit from RASK and selects to

 ;**  to reprint by veteran

 W !!,"Do you want just the Lab/X-ray results" S %=2 D YN^DICN I %=1 H 1 G REN^DVBCLABR ;** Branches to ^DVBCLABR which branches to ^DVBCPRNT

 I %=0 W !!,"Enter Y to get just the Lab/X-ray results for the Vet",!,"or N to get the entire exam results AND Lab/X-ray." H 2 G ONLYLAB

 ;

ADATE ;** Jumped into from RASK or dropped into from ONLYLAB

 I RTYPE="D" S %DT="AE",%DT("A")="Enter original printing date: ",%DT(0)=-DT D ^%DT G:+Y<0 EXIT S RUNDATE=+Y

 ;

WHO ;** Dropped into from ADATE

 W !!,"Reprinted by the RO or MAS ?   >> " R ANS:DTIME G:'$T EXIT I ANS=""!(ANS=U) G EXIT

 I ANS'="R"&(ANS'="r"&(ANS'="m"&(ANS'="M"))) S ANS="E"

 W $S(ANS="M"!(ANS="m"):"AS",ANS="R"!(ANS="r"):"O",1:"")

 S:ANS="r" ANS="R"

 S:ANS="m" ANS="M"

 I ANS'?1"R"&(ANS'?1"M") W !,"Must be R for Regional Office or M for MAS.",!!,*7 G WHO

 I ANS="R" K AUTO ;selects header type

 I ANS="M" S AUTO=1

 I ONE="Y" K OUT D ONEVET I $D(OUT) G EXIT

 ;

DEVICE ;** Dropped into from WHO

 W @IOF S %ZIS="AEQ",%ZIS("B")="0;P-OTHER",%ZIS("A")="Output device: " D ^%ZIS G:POP EXIT

 I $D(IO("Q")),ONE="N" S ZTRTN="GO^DVBCRPRT",ZTIO=ION,ZTDESC="2507 Final Exam Reprint" F I="XDD","D*","PGHD","RTYPE","RUNDATE","Y","AUTO","LOC","ANS","ULINE","ONE" S ZTSAVE(I)=""

 I $D(IO("Q")),ONE="Y" S ZTRTN="OV^DVBCRPON",ZTIO=ION,ZTDESC="Single 2507 Final Exam Reprint" F I="XDD","D*","PGHD","RTYPE","RUNDATE","Y","AUTO","LOC","ANS","ULINE","ONE" S ZTSAVE(I)=""

 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! H 1 G EXIT

 I ONE="N" G GO^DVBCRPRT

 I ONE="Y" G OV

 ;

ONEVET ;** Called from WHO when ONE=Y

 W !! S DIC("W")="D DICW^DVBCUTIL",DIC="^DVB(396.3,",DIC(0)="AEQM" D ^DIC I X=""!(X=U) S OUT=1 Q

 I +Y<0 W *7,"   ???" H 2 G ONEVET

 S DA=+Y

 S RO=$P(^DVB(396.3,DA,0),U,3) I RO'=DUZ(2)&('$D(AUTO))&(SUPER=0) W !!,*7,"Those results do not belong to your office.",!! H 3 G ONEVET

 ;;AJF;Request Status conversion

 N RST

 S RST=$$RSTAT^DVBCUTL8($P(^DVB(396.3,DA,0),U,18))

 I RO=DUZ(2)&('$D(AUTO))&("RC"'[RST) W *7,!!,"This request has not been released to the Regional Office yet.",!! H 3 G ONEVET

 S PRTDATE=$P(^DVB(396.3,DA,0),U,16) I PRTDATE="" W *7,!!,"This has never been printed.",!! I SUPER=0 S OUT=1 H 3 Q

 Q

 ;

OV ;** Run as a background task or in real-time

 U IO S DA(1)=DA K DVBAON2 D SETLAB^DVBCPRNT,VARS^DVBCUTIL,STEP2^DVBCRPRT

 K AUTO D ^%ZISC I '$D(ZTQUEUED) G SETUP1

 ;

EXIT K AUTO S LKILL=1 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL

 ;

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DVBCRPON   3588     printed  Mar 13, 2025@20:53:17                                                                                                                                                                                                    Page 2

DVBCRPON  ;ALB/GTS-557/THM-REPRINT C&P REPORTS ; 7/1/91  1:09 PM

 +1       ;;2.7;AMIE;**2,32,193**;Apr 10, 1995;Build 84

 +2       ;

SETUP      DO HOME^%ZIS

           KILL ULINE

           SET FF=IOF

           SET HD="Reprint C & P Exams"

 +1        SET XDD=^DD("DD")

           SET $PIECE(ULINE,"_",70)="_"

 +2        IF $GET(DUZ(2))<1

               WRITE !!,*7,"Your division code is invalid.",!!

               HANG 2

               GOTO EXIT

 +3        SET SUPER=0

           IF $DATA(^XUSEC("DVBA C SUPERVISOR",DUZ))

               SET SUPER=1

 +4       ;

SETUP1    ;** Drops into if setup is ok

 +1        WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!

 +2        SET ONE="N"

           SET Y=DT

           XECUTE XDD

 +3        SET DVBCDT(0)=Y

           SET PGHD="Compensation and Pension Exam Report"

           SET LOC=DUZ(2)

           SET PG=0

           SET DVBCSITE=$SELECT($DATA(^DVB(396.1,1,0)):$PIECE(^(0),U,1),1:"Not specified")

 +4       ;

RASK       WRITE !!,"Select Reprint Option - (D)ate or (V)eteran:  D// "

           READ RTYPE:DTIME

           IF RTYPE[U!('$TEST)

               GOTO EXIT

 +1        IF RTYPE'=""&(RTYPE'="D"&(RTYPE'="d"&(RTYPE'="v"&(RTYPE'="V"))))

               SET RTYPE="E"

 +2        if RTYPE=""

               WRITE "Date"

           WRITE $SELECT(RTYPE="D"!(RTYPE="d"):"ate",RTYPE="V"!(RTYPE="v"):"eteran",1:"")

           IF RTYPE=""!(RTYPE="d")

               SET RTYPE="D"

 +3        IF RTYPE="v"

               SET RTYPE="V"

 +4        IF RTYPE'?1"D"

               IF RTYPE'?1"V"

                   WRITE !!,"Must be D or V"

                   GOTO RASK

 +5        if RTYPE="D"

               GOTO ADATE

           IF RTYPE="V"

               SET ONE="Y"

 +6       ;

ONLYLAB   ;** Dropped into if the user doesn't exit from RASK and selects to

 +1       ;**  to reprint by veteran

 +2       ;** Branches to ^DVBCLABR which branches to ^DVBCPRNT

           WRITE !!,"Do you want just the Lab/X-ray results"

           SET %=2

           DO YN^DICN

           IF %=1

               HANG 1

               GOTO REN^DVBCLABR

 +3        IF %=0

               WRITE !!,"Enter Y to get just the Lab/X-ray results for the Vet",!,"or N to get the entire exam results AND Lab/X-ray."

               HANG 2

               GOTO ONLYLAB

 +4       ;

ADATE     ;** Jumped into from RASK or dropped into from ONLYLAB

 +1        IF RTYPE="D"

               SET %DT="AE"

               SET %DT("A")="Enter original printing date: "

               SET %DT(0)=-DT

               DO ^%DT

               if +Y<0

                   GOTO EXIT

               SET RUNDATE=+Y

 +2       ;

WHO       ;** Dropped into from ADATE

 +1        WRITE !!,"Reprinted by the RO or MAS ?   >> "

           READ ANS:DTIME

           if '$TEST

               GOTO EXIT

           IF ANS=""!(ANS=U)

               GOTO EXIT

 +2        IF ANS'="R"&(ANS'="r"&(ANS'="m"&(ANS'="M")))

               SET ANS="E"

 +3        WRITE $SELECT(ANS="M"!(ANS="m"):"AS",ANS="R"!(ANS="r"):"O",1:"")

 +4        if ANS="r"

               SET ANS="R"

 +5        if ANS="m"

               SET ANS="M"

 +6        IF ANS'?1"R"&(ANS'?1"M")

               WRITE !,"Must be R for Regional Office or M for MAS.",!!,*7

               GOTO WHO

 +7       ;selects header type

           IF ANS="R"

               KILL AUTO

 +8        IF ANS="M"

               SET AUTO=1

 +9        IF ONE="Y"

               KILL OUT

               DO ONEVET

               IF $DATA(OUT)

                   GOTO EXIT

 +10      ;

DEVICE    ;** Dropped into from WHO

 +1        WRITE @IOF

           SET %ZIS="AEQ"

           SET %ZIS("B")="0;P-OTHER"

           SET %ZIS("A")="Output device: "

           DO ^%ZIS

           if POP

               GOTO EXIT

 +2        IF $DATA(IO("Q"))

               IF ONE="N"

                   SET ZTRTN="GO^DVBCRPRT"

                   SET ZTIO=ION

                   SET ZTDESC="2507 Final Exam Reprint"

                   FOR I="XDD","D*","PGHD","RTYPE","RUNDATE","Y","AUTO","LOC","ANS","ULINE","ONE"

                       SET ZTSAVE(I)=""

 +3        IF $DATA(IO("Q"))

               IF ONE="Y"

                   SET ZTRTN="OV^DVBCRPON"

                   SET ZTIO=ION

                   SET ZTDESC="Single 2507 Final Exam Reprint"

                   FOR I="XDD","D*","PGHD","RTYPE","RUNDATE","Y","AUTO","LOC","ANS","ULINE","ONE"

                       SET ZTSAVE(I)=""

 +4        IF $DATA(IO("Q"))

               DO ^%ZTLOAD

               if $DATA(ZTSK)

                   WRITE !!,"Request queued",!!

               HANG 1

               GOTO EXIT

 +5        IF ONE="N"

               GOTO GO^DVBCRPRT

 +6        IF ONE="Y"

               GOTO OV

 +7       ;

ONEVET    ;** Called from WHO when ONE=Y

 +1        WRITE !!

           SET DIC("W")="D DICW^DVBCUTIL"

           SET DIC="^DVB(396.3,"

           SET DIC(0)="AEQM"

           DO ^DIC

           IF X=""!(X=U)

               SET OUT=1

               QUIT 

 +2        IF +Y<0

               WRITE *7,"   ???"

               HANG 2

               GOTO ONEVET

 +3        SET DA=+Y

 +4        SET RO=$PIECE(^DVB(396.3,DA,0),U,3)

           IF RO'=DUZ(2)&('$DATA(AUTO))&(SUPER=0)

               WRITE !!,*7,"Those results do not belong to your office.",!!

               HANG 3

               GOTO ONEVET

 +5       ;;AJF;Request Status conversion

 +6        NEW RST

 +7        SET RST=$$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,DA,0),U,18))

 +8        IF RO=DUZ(2)&('$DATA(AUTO))&("RC"'[RST)

               WRITE *7,!!,"This request has not been released to the Regional Office yet.",!!

               HANG 3

               GOTO ONEVET

 +9        SET PRTDATE=$PIECE(^DVB(396.3,DA,0),U,16)

           IF PRTDATE=""

               WRITE *7,!!,"This has never been printed.",!!

               IF SUPER=0

                   SET OUT=1

                   HANG 3

                   QUIT 

 +10       QUIT 

 +11      ;

OV        ;** Run as a background task or in real-time

 +1        USE IO

           SET DA(1)=DA

           KILL DVBAON2

           DO SETLAB^DVBCPRNT

           DO VARS^DVBCUTIL

           DO STEP2^DVBCRPRT

 +2        KILL AUTO

           DO ^%ZISC

           IF '$DATA(ZTQUEUED)

               GOTO SETUP1

 +3       ;

EXIT       KILL AUTO

           SET LKILL=1

           if $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

           GOTO KILL^DVBCUTIL

 +1       ;

 +2        QUIT