DVBCPRNT ;ALB/GTS-557/THM-FINAL REPORT DRIVER ; 5/17/91 10:29 AM
;;2.7;AMIE;**193,221**;Apr 10, 1995;Build 4
;
I '$D(DUZ(2)) W *7,!!,"You DIVISION NUMBER is incorrect.",! H 2 Q
I DUZ(2)<1 W !,*7,"Your DIVISION NUMBER is invalid.",! H 2 Q
;
SETUP K EDPRT,ULINE S XDD=^DD("DD"),$P(ULINE,"_",70)="_" K AUTO
D HOME^%ZIS S FF=IOF,HD="C & P Exam Printing" W @IOF,!?(IOM-$L(HD)\2),HD,!!!
S Y=DT X XDD S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")
W !!,"Note: All reports will be produced in 'terminal-digit' order.",!! H 1
;
DEVICE S %ZIS="AEQ",%ZIS("B")="0;P-OTHER",%ZIS("A")="Output device: " D ^%ZIS G:POP KILL^DVBCUTIL
I $D(IO("Q")) S ZTRTN="GO^DVBCPRNT",ZTIO=ION,ZTDESC="2507 Final Exam Report" F I="D*","XDD","ULINE","HD","FF","PGHD" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued",!! K ZTSK G KILL^DVBCUTIL
;
GO D STM^DVBCUTL4
U IO K ^TMP($J) D HDA S (XCNT,XPRINT)=0
;AJF;Request Status conversion
F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AF",4,DUZ(2),DA(1))) Q:DA(1)="" DO
.I $D(^DVB(396.3,DA(1),0)) D GO1 S XPRINT=1,XCNT=XCNT+1
.I '$D(^DVB(396.3,DA(1),0)) D BADXRF
I XPRINT=0 K XPRINT,XPG,XXLN W !!!!!?25,"Nothing to print",!! H 2 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
I XCNT>0,XPRINT=1 W !!,"Total requests to be printed: ",XCNT,!
K XCNT,XXLN,XPG,XPRINT,OUT
D SETLAB
S (XCN,PNAM)=""
S XCN=0 F S XCN=$O(^TMP($J,XCN)) Q:XCN="" F JJ=0:0 S PNAM=$O(^TMP($J,XCN,PNAM)) Q:PNAM="" K PRINT F DA(1)=0:0 S DA(1)=$O(^TMP($J,XCN,PNAM,DA(1))) Q:DA(1)="" S DA=DA(1) D VARS^DVBCUTIL,STEP2^DVBCPRN1 I '$D(AUTO) D ^DVBCLABR,LKILL^DVBCUTL3
S XRTN=$T(+0)
D SPM^DVBCUTL4
K DVBCN S LKILL=1 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
;
GO1 S DFN=$P(^DVB(396.3,DA(1),0),U,1),PNAM=$P(^DPT(DFN,0),U,1) W $E(PNAM,1,25),?28,$E($P(^(0),U,9),1,3)_" "_$E($P(^(0),U,9),4,5)_" "_$E($P(^(0),U,9),6,9)
S CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Missing") W ?43,CNUM,?55 S Y=$P(^DVB(396.3,DA(1),0),U,2) X XDD W Y,! D:$Y>(IOSL-16) HDA
S XCN=$E(CNUM,$L(CNUM)-1,$L(CNUM)),XCN=+XCN
I XCN=0 S XCN=$P(^DPT(DFN,0),U,9) ;ICR #10035
I PNAM]"" S ^TMP($J,XCN,PNAM,DA(1))=""
K PNAM,XCN,CNUM
Q
;
SETLAB N XX S XX=1,DVBCRALC(XX)="^",Y=0
F S Y=$O(^DVB(396.1,1,4,"B",Y)) Q:(Y="") I $D(^SC(+Y,0)) S DVBCRALC(XX)=DVBCRALC(XX)_+Y_U I $L(DVBCRALC(XX))>230 S XX=XX+1,DVBCRALC(XX)="^"
Q
;
HDA S:'$D(XPG) XPG=0 S XPG=XPG+1
I (IOST?1"C-".E)!($D(DVBAON2)) W @IOF
S:('$D(DVBAON2)) DVBAON2=""
W !,"Final C&P Reports for print date " S Y=DT X XDD W Y,!!,"Operator: ",$S($D(^VA(200,+DUZ,0)):$P(^(0),U,1),1:"Unknown operator"),!,"Location: ",$S($D(^DIC(4,+DUZ(2),0)):$P(^(0),U,1),1:"Unknown location"),!
W !,"Veteran Name",?28,"SSN",?43,"C-Number",?55,"Request date",!
F XXLN=1:1:79 W "-"
W !!
Q
;
WARN W !!,*7,"Too many locations to store! Some locations may not be reported.",!! H 3 S OUT=1
Q
;
BADXRF ; ** Display a message that a bad cross reference exists **
W !,"A bad 'D' X-Reference exists on the 2507 Request File (#396.3) for"
W " DA="_DA(1)_"."
W !,"Please notify IRM at the facility where you have created"
W " this report.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCPRNT 3205 printed Sep 23, 2025@19:21:21 Page 2
DVBCPRNT ;ALB/GTS-557/THM-FINAL REPORT DRIVER ; 5/17/91 10:29 AM
+1 ;;2.7;AMIE;**193,221**;Apr 10, 1995;Build 4
+2 ;
+3 IF '$DATA(DUZ(2))
WRITE *7,!!,"You DIVISION NUMBER is incorrect.",!
HANG 2
QUIT
+4 IF DUZ(2)<1
WRITE !,*7,"Your DIVISION NUMBER is invalid.",!
HANG 2
QUIT
+5 ;
SETUP KILL EDPRT,ULINE
SET XDD=^DD("DD")
SET $PIECE(ULINE,"_",70)="_"
KILL AUTO
+1 DO HOME^%ZIS
SET FF=IOF
SET HD="C & P Exam Printing"
WRITE @IOF,!?(IOM-$LENGTH(HD)\2),HD,!!!
+2 SET Y=DT
XECUTE XDD
SET DVBCDT(0)=Y
SET PGHD="Compensation and Pension Exam Report"
SET DVBCSITE=$SELECT($DATA(^DVB(396.1,1,0)):$PIECE(^(0),U,1),1:"Not specified")
+3 WRITE !!,"Note: All reports will be produced in 'terminal-digit' order.",!!
HANG 1
+4 ;
DEVICE SET %ZIS="AEQ"
SET %ZIS("B")="0;P-OTHER"
SET %ZIS("A")="Output device: "
DO ^%ZIS
if POP
GOTO KILL^DVBCUTIL
+1 IF $DATA(IO("Q"))
SET ZTRTN="GO^DVBCPRNT"
SET ZTIO=ION
SET ZTDESC="2507 Final Exam Report"
FOR I="D*","XDD","ULINE","HD","FF","PGHD"
SET ZTSAVE(I)=""
+2 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
KILL ZTSK
GOTO KILL^DVBCUTIL
+3 ;
GO DO STM^DVBCUTL4
+1 USE IO
KILL ^TMP($JOB)
DO HDA
SET (XCNT,XPRINT)=0
+2 ;AJF;Request Status conversion
+3 FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AF",4,DUZ(2),DA(1)))
if DA(1)=""
QUIT
Begin DoDot:1
+4 IF $DATA(^DVB(396.3,DA(1),0))
DO GO1
SET XPRINT=1
SET XCNT=XCNT+1
+5 IF '$DATA(^DVB(396.3,DA(1),0))
DO BADXRF
End DoDot:1
+6 IF XPRINT=0
KILL XPRINT,XPG,XXLN
WRITE !!!!!?25,"Nothing to print",!!
HANG 2
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBCUTIL
+7 IF XCNT>0
IF XPRINT=1
WRITE !!,"Total requests to be printed: ",XCNT,!
+8 KILL XCNT,XXLN,XPG,XPRINT,OUT
+9 DO SETLAB
+10 SET (XCN,PNAM)=""
+11 SET XCN=0
FOR
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""
QUIT
FOR JJ=0:0
SET PNAM=$ORDER(^TMP($JOB,XCN,PNAM))
if PNAM=""
QUIT
KILL PRINT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^TMP($JOB,XCN,PNAM,DA(1)))
if DA(1)=""
QUIT
SET DA=DA(1)
DO VARS^DVBCUTIL
DO STEP2^DVBCPRN1
IF '$DATA(AUTO)
DO ^DVBCLABR
DO LKILL^DVBCUTL3
+12 SET XRTN=$TEXT(+0)
+13 DO SPM^DVBCUTL4
+14 KILL DVBCN
SET LKILL=1
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBCUTIL
+15 ;
GO1 SET DFN=$PIECE(^DVB(396.3,DA(1),0),U,1)
SET PNAM=$PIECE(^DPT(DFN,0),U,1)
WRITE $EXTRACT(PNAM,1,25),?28,$EXTRACT($PIECE(^(0),U,9),1,3)_" "_$EXTRACT($PIECE(^(0),U,9),4,5)_" "_$EXTRACT($PIECE(^(0),U,9),6,9)
+1 SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Missing")
WRITE ?43,CNUM,?55
SET Y=$PIECE(^DVB(396.3,DA(1),0),U,2)
XECUTE XDD
WRITE Y,!
if $Y>(IOSL-16)
DO HDA
+2 SET XCN=$EXTRACT(CNUM,$LENGTH(CNUM)-1,$LENGTH(CNUM))
SET XCN=+XCN
+3 ;ICR #10035
IF XCN=0
SET XCN=$PIECE(^DPT(DFN,0),U,9)
+4 IF PNAM]""
SET ^TMP($JOB,XCN,PNAM,DA(1))=""
+5 KILL PNAM,XCN,CNUM
+6 QUIT
+7 ;
SETLAB NEW XX
SET XX=1
SET DVBCRALC(XX)="^"
SET Y=0
+1 FOR
SET Y=$ORDER(^DVB(396.1,1,4,"B",Y))
if (Y="")
QUIT
IF $DATA(^SC(+Y,0))
SET DVBCRALC(XX)=DVBCRALC(XX)_+Y_U
IF $LENGTH(DVBCRALC(XX))>230
SET XX=XX+1
SET DVBCRALC(XX)="^"
+2 QUIT
+3 ;
HDA if '$DATA(XPG)
SET XPG=0
SET XPG=XPG+1
+1 IF (IOST?1"C-".E)!($DATA(DVBAON2))
WRITE @IOF
+2 if ('$DATA(DVBAON2))
SET DVBAON2=""
+3 WRITE !,"Final C&P Reports for print date "
SET Y=DT
XECUTE XDD
WRITE Y,!!,"Operator: ",$SELECT($DATA(^VA(200,+DUZ,0)):$PIECE(^(0),U,1),1:"Unknown operator"),!,"Location: ",$SELECT($DATA(^DIC(4,+DUZ(2),0)):$PIECE(^(0),U,1),1:"Unknown location"),!
+4 WRITE !,"Veteran Name",?28,"SSN",?43,"C-Number",?55,"Request date",!
+5 FOR XXLN=1:1:79
WRITE "-"
+6 WRITE !!
+7 QUIT
+8 ;
WARN WRITE !!,*7,"Too many locations to store! Some locations may not be reported.",!!
HANG 3
SET OUT=1
+1 QUIT
+2 ;
BADXRF ; ** Display a message that a bad cross reference exists **
+1 WRITE !,"A bad 'D' X-Reference exists on the 2507 Request File (#396.3) for"
+2 WRITE " DA="_DA(1)_"."
+3 WRITE !,"Please notify IRM at the facility where you have created"
+4 WRITE " this report.",!!
+5 QUIT
