- 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 Feb 18, 2025@23:11:44 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