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 ---[H[J[2J[HDVBCRPON 3588 printed Dec 13, 2024@01:48:35 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
