DVBCRPRT ;ALB/GTS-557/THM-REPRINT C&P REPORT ; 5/17/91 10:28 AM
;;2.7;AMIE;**31,42,119,192,196,193**;Apr 10, 1995;Build 84
;
; ** DVBCRPRT is called from DVBCRPON **
; ** DVBCRPRT is called from DVBAB82 **
PHYS S PHYS=$S($D(^DVB(396.4,DA,0)):$P(^(0),U,7),1:"")
Q
STEP2A ; ** Called from STEP2 only **
S EXMNM=$S($D(^DVB(396.6,$P(^DVB(396.4,DA,0),U,3),0)):$P(^(0),U,1),1:"Unknown exam"),EXHD="For "_EXMNM_" Exam" D HDR^DVBCRPR1
W "Examining provider: ",PHYS,!,"Examined on: " S Y=$P(^DVB(396.4,DA,0),U,6) X XDD W Y,! F LINE=1:1:80 W "="
W !!?2,"Examination results:",!! S EXSTAT=$P(^DVB(396.4,DA,0),U,4) I EXSTAT="X"!(EXSTAT="RX") W !!!!!?25,"This exam was CANCELLED by ",$S(EXSTAT="RX":"the RO.",1:"MAS."),!! Q
D STEP3
Q
STEP2 ; ** An external entry point and called from GO2 **
F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:DA="" D GETRO Q:RO'=DUZ(2)&('$D(^XUSEC("DVBA C SUPERVISOR",DUZ))) S PG=0 D PHYS,STEP2A I $D(PRINT) D BOT^DVBCRPR1 K PRINT
D ^DVBCLABR Q
K DVBAON2
Q
VBASTEP2 ; call from VBACRPON^DVBAB82
F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:DA="" D GETRO S PG=0 D PHYS,STEP2A I $D(PRINT) D BOT^DVBCRPR1 K PRINT
D ^DVBCLABR Q
K DVBAON2
Q
STEP3 ; ** Called from STEP2A only **
K ^UTILITY($J,"W") S DIWL=1,DIWR=80,DIWF="NW" S OLDA=DA,OLDA1=DA(1)
F LINE=0:0 S LINE=$O(^DVB(396.4,OLDA,"RES",LINE)) Q:LINE="" S X=^DVB(396.4,OLDA,"RES",LINE,0) D ^DIWP,STEP3A
D ^DIWW S PRINT=1 S DA=OLDA,DA(1)=OLDA1
Q
STEP3A ; ** Called from STEP3 only **
I +$G(DVBGUI) D
.I $Y>(IOSL-9) D HDR^DVBCRPR1
I '+$G(DVBGUI) D
.I $Y>(IOSL-9) D UP^DVBCRPR1,NEXT,HDR^DVBCRPR1 W:$O(^DVB(396.4,OLDA,"RES",LINE))]""&('+$G(DVBGUI)) !!,"Exam Results Continued",!!
Q
GO ; ** An external entry point called from DVBCRPON **
U IO K ^TMP($J),DVBAON2 D HDA^DVBCRPR1 S (XCNT,XPRINT)=0
I '$D(^XUSEC("DVBA C SUPERVISOR",DUZ)) D
.F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AF",5,DUZ(2),DA(1))) Q:DA(1)="" DO
..I $D(^DVB(396.3,DA(1),0)) D GO1
..I '$D(^DVB(396.3,DA(1),0)) D BADXRF^DVBCPRNT
I $D(^XUSEC("DVBA C SUPERVISOR",DUZ)) D
.;AJF;Request Status conversion
.F LOC=0:0 S LOC=$O(^DVB(396.3,"AF",5,LOC)) Q:LOC="" D
..F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AF",5,LOC,DA(1))) Q:DA(1)="" DO
...I $D(^DVB(396.3,DA(1),0)) D GO1
...I '$D(^DVB(396.3,DA(1),0)) D BADXRF^DVBCPRNT
I XPRINT=0 K XPRINT,XPG,XXLN W !!!!!?25,"Nothing to print",!! H 2 G KILL^DVBCUTIL
I XCNT>0,XPRINT=1 W !!,"Total requests to be printed: ",XCNT,!
K XCNT,XXLN,XPG,XPRINT D SETLAB^DVBCPRNT S (XCN,PNAM)=""
F DVBCN=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN="" F JJ=0:0 S PNAM=$O(^TMP($J,XCN,PNAM)) Q:PNAM="" D GO2
G EXIT
VBAGO ; ** An external entry point called from DVBCRPON **
U IO K ^TMP($J),DVBAON2 D HDA^DVBCRPR1 S (XCNT,XPRINT)=0
D
.S DVBADUZ(2)=$P(^DVB(396.3,DA(1),0),U,2)
.F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AF",5,DVBADUZ(2),DA(1))) Q:DA(1)="" DO
..I $D(^DVB(396.3,DA(1),0)) D GO1
..I '$D(^DVB(396.3,DA(1),0)) D BADXRF^DVBCPRNT
I XPRINT=0 K XPRINT,XPG,XXLN W !!!!!?25,"Nothing to print",!! H 2 G KILL^DVBCUTIL
I XCNT>0,XPRINT=1 W !!,"Total requests to be printed: ",XCNT,!
K XCNT,XXLN,XPG,XPRINT D SETLAB^DVBCPRNT S (XCN,PNAM)=""
F DVBCN=0:0 S XCN=$O(^TMP($J,XCN)) Q:XCN="" F JJ=0:0 S PNAM=$O(^TMP($J,XCN,PNAM)) Q:PNAM="" D GO2
G EXIT
GO2 F DA(1)=0:0 K PRINT S DA(1)=$O(^TMP($J,XCN,PNAM,DA(1))) Q:DA(1)="" S PRTDATE=$P(^DVB(396.3,DA(1),0),U,16) I PRTDATE[RUNDATE S DA=DA(1) D VARS^DVBCUTIL Q:(LOC'=RO)&('$D(^XUSEC("DVBA C SUPERVISOR",DUZ)))&('$D(AUTO)) D STEP2
Q
GO1 S DFN=$P(^DVB(396.3,DA(1),0),U,1),PRTDATE=$P(^(0),U,16),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Missing")
I RTYPE="D" Q:PRTDATE'[RUNDATE!(RUNDATE']"")
S XCN=$E(CNUM,$L(CNUM)-1,$L(CNUM)),XCN=+XCN
I PNAM]"" S ^TMP($J,XCN,PNAM,DA(1))="",XPRINT=1,XCNT=XCNT+1
D SSNSHRT^DVBCUTIL
W $E(PNAM,1,25),?28,DVBCSSNO,?43,CNUM,?55 S Y=$P(^DVB(396.3,DA(1),0),U,2) X XDD W Y,! D:$Y>(IOSL-16) HDA^DVBCRPR1
K PNAM,XCN,CNUM,DVBCSSNO
Q
;
EXIT K XDD,AUTO,DVBADUZ(2) S LKILL=1 G KILL^DVBCUTIL ; ** GOTO will quit from this RTN
;
NEXT I '$D(DVBGUI) W !,"Continued on next page",!,"VA Form 2507"
Q
;
GETRO S RO=$P(^DVB(396.3,DA(1),0),U,3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCRPRT 4218 printed Jan 18, 2025@02:49:50 Page 2
DVBCRPRT ;ALB/GTS-557/THM-REPRINT C&P REPORT ; 5/17/91 10:28 AM
+1 ;;2.7;AMIE;**31,42,119,192,196,193**;Apr 10, 1995;Build 84
+2 ;
+3 ; ** DVBCRPRT is called from DVBCRPON **
+4 ; ** DVBCRPRT is called from DVBAB82 **
PHYS SET PHYS=$SELECT($DATA(^DVB(396.4,DA,0)):$PIECE(^(0),U,7),1:"")
+1 QUIT
STEP2A ; ** Called from STEP2 only **
+1 SET EXMNM=$SELECT($DATA(^DVB(396.6,$PIECE(^DVB(396.4,DA,0),U,3),0)):$PIECE(^(0),U,1),1:"Unknown exam")
SET EXHD="For "_EXMNM_" Exam"
DO HDR^DVBCRPR1
+2 WRITE "Examining provider: ",PHYS,!,"Examined on: "
SET Y=$PIECE(^DVB(396.4,DA,0),U,6)
XECUTE XDD
WRITE Y,!
FOR LINE=1:1:80
WRITE "="
+3 WRITE !!?2,"Examination results:",!!
SET EXSTAT=$PIECE(^DVB(396.4,DA,0),U,4)
IF EXSTAT="X"!(EXSTAT="RX")
WRITE !!!!!?25,"This exam was CANCELLED by ",$SELECT(EXSTAT="RX":"the RO.",1:"MAS."),!!
QUIT
+4 DO STEP3
+5 QUIT
STEP2 ; ** An external entry point and called from GO2 **
+1 FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",DA(1),DA))
if DA=""
QUIT
DO GETRO
if RO'=DUZ(2)&('$DATA(^XUSEC("DVBA C SUPERVISOR",DUZ)))
QUIT
SET PG=0
DO PHYS
DO STEP2A
IF $DATA(PRINT)
DO BOT^DVBCRPR1
KILL PRINT
+2 DO ^DVBCLABR
QUIT
+3 KILL DVBAON2
+4 QUIT
VBASTEP2 ; call from VBACRPON^DVBAB82
+1 FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",DA(1),DA))
if DA=""
QUIT
DO GETRO
SET PG=0
DO PHYS
DO STEP2A
IF $DATA(PRINT)
DO BOT^DVBCRPR1
KILL PRINT
+2 DO ^DVBCLABR
QUIT
+3 KILL DVBAON2
+4 QUIT
STEP3 ; ** Called from STEP2A only **
+1 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=80
SET DIWF="NW"
SET OLDA=DA
SET OLDA1=DA(1)
+2 FOR LINE=0:0
SET LINE=$ORDER(^DVB(396.4,OLDA,"RES",LINE))
if LINE=""
QUIT
SET X=^DVB(396.4,OLDA,"RES",LINE,0)
DO ^DIWP
DO STEP3A
+3 DO ^DIWW
SET PRINT=1
SET DA=OLDA
SET DA(1)=OLDA1
+4 QUIT
STEP3A ; ** Called from STEP3 only **
+1 IF +$GET(DVBGUI)
Begin DoDot:1
+2 IF $Y>(IOSL-9)
DO HDR^DVBCRPR1
End DoDot:1
+3 IF '+$GET(DVBGUI)
Begin DoDot:1
+4 IF $Y>(IOSL-9)
DO UP^DVBCRPR1
DO NEXT
DO HDR^DVBCRPR1
if $ORDER(^DVB(396.4,OLDA,"RES",LINE))]""&('+$GET(DVBGUI))
WRITE !!,"Exam Results Continued",!!
End DoDot:1
+5 QUIT
GO ; ** An external entry point called from DVBCRPON **
+1 USE IO
KILL ^TMP($JOB),DVBAON2
DO HDA^DVBCRPR1
SET (XCNT,XPRINT)=0
+2 IF '$DATA(^XUSEC("DVBA C SUPERVISOR",DUZ))
Begin DoDot:1
+3 FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AF",5,DUZ(2),DA(1)))
if DA(1)=""
QUIT
Begin DoDot:2
+4 IF $DATA(^DVB(396.3,DA(1),0))
DO GO1
+5 IF '$DATA(^DVB(396.3,DA(1),0))
DO BADXRF^DVBCPRNT
End DoDot:2
End DoDot:1
+6 IF $DATA(^XUSEC("DVBA C SUPERVISOR",DUZ))
Begin DoDot:1
+7 ;AJF;Request Status conversion
+8 FOR LOC=0:0
SET LOC=$ORDER(^DVB(396.3,"AF",5,LOC))
if LOC=""
QUIT
Begin DoDot:2
+9 FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AF",5,LOC,DA(1)))
if DA(1)=""
QUIT
Begin DoDot:3
+10 IF $DATA(^DVB(396.3,DA(1),0))
DO GO1
+11 IF '$DATA(^DVB(396.3,DA(1),0))
DO BADXRF^DVBCPRNT
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF XPRINT=0
KILL XPRINT,XPG,XXLN
WRITE !!!!!?25,"Nothing to print",!!
HANG 2
GOTO KILL^DVBCUTIL
+13 IF XCNT>0
IF XPRINT=1
WRITE !!,"Total requests to be printed: ",XCNT,!
+14 KILL XCNT,XXLN,XPG,XPRINT
DO SETLAB^DVBCPRNT
SET (XCN,PNAM)=""
+15 FOR DVBCN=0:0
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""
QUIT
FOR JJ=0:0
SET PNAM=$ORDER(^TMP($JOB,XCN,PNAM))
if PNAM=""
QUIT
DO GO2
+16 GOTO EXIT
VBAGO ; ** An external entry point called from DVBCRPON **
+1 USE IO
KILL ^TMP($JOB),DVBAON2
DO HDA^DVBCRPR1
SET (XCNT,XPRINT)=0
+2 Begin DoDot:1
+3 SET DVBADUZ(2)=$PIECE(^DVB(396.3,DA(1),0),U,2)
+4 FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AF",5,DVBADUZ(2),DA(1)))
if DA(1)=""
QUIT
Begin DoDot:2
+5 IF $DATA(^DVB(396.3,DA(1),0))
DO GO1
+6 IF '$DATA(^DVB(396.3,DA(1),0))
DO BADXRF^DVBCPRNT
End DoDot:2
End DoDot:1
+7 IF XPRINT=0
KILL XPRINT,XPG,XXLN
WRITE !!!!!?25,"Nothing to print",!!
HANG 2
GOTO KILL^DVBCUTIL
+8 IF XCNT>0
IF XPRINT=1
WRITE !!,"Total requests to be printed: ",XCNT,!
+9 KILL XCNT,XXLN,XPG,XPRINT
DO SETLAB^DVBCPRNT
SET (XCN,PNAM)=""
+10 FOR DVBCN=0:0
SET XCN=$ORDER(^TMP($JOB,XCN))
if XCN=""
QUIT
FOR JJ=0:0
SET PNAM=$ORDER(^TMP($JOB,XCN,PNAM))
if PNAM=""
QUIT
DO GO2
+11 GOTO EXIT
GO2 FOR DA(1)=0:0
KILL PRINT
SET DA(1)=$ORDER(^TMP($JOB,XCN,PNAM,DA(1)))
if DA(1)=""
QUIT
SET PRTDATE=$PIECE(^DVB(396.3,DA(1),0),U,16)
IF PRTDATE[RUNDATE
SET DA=DA(1)
DO VARS^DVBCUTIL
if (LOC'=RO)&('$DATA(^XUSEC("DVBA C SUPERVISOR",DUZ)))&('$DATA(AUTO))
QUIT
DO STEP2
+1 QUIT
GO1 SET DFN=$PIECE(^DVB(396.3,DA(1),0),U,1)
SET PRTDATE=$PIECE(^(0),U,16)
SET PNAM=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
SET CNUM=$SELECT($DATA(^DPT(DFN,.31)):$PIECE(^(.31),U,3),1:"Missing")
+1 IF RTYPE="D"
if PRTDATE'[RUNDATE!(RUNDATE']"")
QUIT
+2 SET XCN=$EXTRACT(CNUM,$LENGTH(CNUM)-1,$LENGTH(CNUM))
SET XCN=+XCN
+3 IF PNAM]""
SET ^TMP($JOB,XCN,PNAM,DA(1))=""
SET XPRINT=1
SET XCNT=XCNT+1
+4 DO SSNSHRT^DVBCUTIL
+5 WRITE $EXTRACT(PNAM,1,25),?28,DVBCSSNO,?43,CNUM,?55
SET Y=$PIECE(^DVB(396.3,DA(1),0),U,2)
XECUTE XDD
WRITE Y,!
if $Y>(IOSL-16)
DO HDA^DVBCRPR1
+6 KILL PNAM,XCN,CNUM,DVBCSSNO
+7 QUIT
+8 ;
EXIT ; ** GOTO will quit from this RTN
KILL XDD,AUTO,DVBADUZ(2)
SET LKILL=1
GOTO KILL^DVBCUTIL
+1 ;
NEXT IF '$DATA(DVBGUI)
WRITE !,"Continued on next page",!,"VA Form 2507"
+1 QUIT
+2 ;
GETRO SET RO=$PIECE(^DVB(396.3,DA(1),0),U,3)
+1 QUIT
