DVBCADE1 ;ALB/GTS-557/THM-PRINT/REPRINT WORKSHEETS ; 5/7/91 11:20 AM
;;2.7;AMIE;**12**;Apr 10, 1995
;from DVBCADEX
K RPRT I '$D(^TMP($J,"NEW")) W !!,"No exams selected ...",!! H 2 Q
D COPY G EN
;
CK1 I $P(^DVB(396.4,EXDA,0),U,4)'="O"!($P(^(0),U,5)="Y"),'$D(RPRT) Q
K CMBN I $P(TEMP("NEW",ZC,EXMNM),U,2)="A" S CMBN=1
S PGM=$S($D(^DVB(396.6,JY,0)):$P(^(0),U,4),1:"")
I PGM="" Q
S TNAM=$P(^(0),U,1),PGM="^"_PGM D @PGM
N DVBCEXM S DVBCEXM=EXMNM K DVBCFF
I ZC="A" DO
.S DVBCEXM=$O(TEMP("NEW","A",DVBCEXM))
.I DVBCEXM'="" S DVBCFF=""
.I '$D(DVBCFF) S DVBCEXM=$O(TEMP("NEW","Z","")) DO
..I DVBCEXM'="" S DVBCFF=""
I ZC="Z" DO
.S DVBCEXM=$O(TEMP("NEW","Z",DVBCEXM))
.I DVBCEXM'="" S DVBCFF=""
W:(IOST?1"P-".E)&($D(DVBCFF)) @IOF
K DVBCFF,DVBCEXM
S $P(^DVB(396.4,EXDA,0),U,5)="Y"
K CMBN,TNAM,PGM Q
;
EN W @FF,!!,"Worksheets should be sent to a printer." S %ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS Q:POP K %ZIS
;
QUE I $D(IO("Q")) S ZTRTN=$S($D(RPRT):"GO2^DVBCADE1",1:"GO^DVBCADE1"),ZTDESC="Print C&P Work Sheets" F I="DUZ","DA*","DFN","TEMP*","REQDA","OWNDOM","RPRT","C*","SSN","PNAM" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD S:'$D(ZTSK) POP=1 W:$D(ZTSK) !!,"Request queued",!! H 1 K IO("Q"),ZTRTN,ZTIO,ZTDESC K:'$D(RPRT) ZTSK Q
Q:$D(RPRT)
;
GO U IO S DA=REQDA D VARS^DVBCUTIL
S EXMNM="" F ZC="A","Z" F JZ=0:0 S EXMNM=$O(TEMP("NEW",ZC,EXMNM)) Q:EXMNM="" S JY=$P(TEMP("NEW",ZC,EXMNM),U,1),EXDA=$P(TEMP("NEW",ZC,EXMNM),U,3) D CK1
D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD Q
;
SET S EXDA=+Y,JY=$P(Y,U,2) D EXMNM I '$D(OUT) D FMT D:$D(OUT) QUES Q:$D(OUT) I '$D(OUT) S ^TMP($J,"NEW",EXMNM)=JY_U_FMT_U_EXDA H 1 W @FF,!!,HD4,!!!
Q
;
;print/reprint worksheets
RPRT S RPRT=1 D HOME^%ZIS S FF=IOF
;
EN1 K ^TMP($J),DA,EXDA,EXMNM,OUT,DIC
W @FF,!,"Print/Reprint C&P Worksheets",!!!
S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("A")="Select VETERAN NAME: "
D ^DIC G:X=""!(X=U) EXIT S (REQDA,DA(1))=+Y
S HD4="Select exam(s) to print or enter ALL to print all exams."
W !!,HD4,!!!
K OUT,OUT1
F I=0:0 K DIC,Y,D S DIC("A")="Select EXAM: " W ?10,DIC("A") S DIC="^DVB(396.6,",DIC("S")="I $D(^DVB(396.4,""ARQ""_REQDA,+Y))",DIC(0)="EQ" R X:DTIME S:'$T OUT1=1 Q:$D(OUT1)!(X="")!(X=U)!(X="ALL")!(X="all") DO
.D ^DIC D:X["?" QUES W:+Y<0 !!
.I +Y>0 K DIC S X=+Y,DIC="^DVB(396.4,",DIC(0)="EQ",D="ARQ"_REQDA DO
..D MIX^DIC1 K DIC,D
.I +Y>0 D SET
G:$D(OUT1) EXIT
I $D(X),X="ALL"!(X="all") F EXDA=0:0 S EXDA=$O(^DVB(396.4,"C",REQDA,EXDA)) Q:EXDA="" D FMT G:$D(OUT1) EXIT Q:$D(OUT) S ^TMP($J,"NEW",EXMNM)=JY_U_FMT_U_EXDA
I '$D(^TMP($J,"NEW")) W *7,!!,"No exams selected ..." H 2 G EN1
D COPY,EN G:POP EXIT I $D(ZTSK) K ZTSK G EN1
;
GO2 U IO S DA=DA(1) D VARS^DVBCUTIL
S OWNDOM=$P(^DVB(396.3,DA(1),0),U,22) I OWNDOM]"" D ^DVBCTRNN
S EXMNM="" F ZC="A","Z" F JZ=0:0 S EXMNM=$O(TEMP("NEW",ZC,EXMNM)) Q:EXMNM="" S JY=$P(TEMP("NEW",ZC,EXMNM),U,1),EXDA=$P(TEMP("NEW",ZC,EXMNM),U,3) D CK1
D ^%ZISC G:'$D(ZTQUEUED) EN1 I $D(ZTQUEUED) G EXIT
;
EXMNM K OUT S JY=$P(^DVB(396.4,EXDA,0),U,3)
S EXMNM=$S($D(^DVB(396.6,JY,0)):$P(^(0),U,1),1:"")
I EXMNM="" S OUT=1 ;!($D(^TMP($J,"NEW",EXMNM))) S OUT=1
Q
;
FMT W @IOF,! D EXMNM W !!?10,EXMNM,!
K OUT,OUT1 I $P(^DVB(396.4,EXDA,0),U,4)'="O" W *7,!!?5,"Status is not OPEN - No worksheet will be printed. " H 3 S OUT=1 Q
S FMT="F"
Q
;
COPY K TEMP S X="" F Y=0:0 S X=$O(^TMP($J,"NEW",X)) Q:X="" S Z=$S($P(^TMP($J,"NEW",X),U,2)="F":"A",1:"Z"),TEMP("NEW",Z,X)=^TMP($J,"NEW",X) ;full come out first
Q
;
QUES W !!,"Press RETURN to continue " R ANS:DTIME
W @FF,!!,HD4,!!!
Q
;
EXIT K RPRT,FMT,OUT,OUT1 D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCADE1 3680 printed Nov 22, 2024@16:53:32 Page 2
DVBCADE1 ;ALB/GTS-557/THM-PRINT/REPRINT WORKSHEETS ; 5/7/91 11:20 AM
+1 ;;2.7;AMIE;**12**;Apr 10, 1995
+2 ;from DVBCADEX
+3 KILL RPRT
IF '$DATA(^TMP($JOB,"NEW"))
WRITE !!,"No exams selected ...",!!
HANG 2
QUIT
+4 DO COPY
GOTO EN
+5 ;
CK1 IF $PIECE(^DVB(396.4,EXDA,0),U,4)'="O"!($PIECE(^(0),U,5)="Y")
IF '$DATA(RPRT)
QUIT
+1 KILL CMBN
IF $PIECE(TEMP("NEW",ZC,EXMNM),U,2)="A"
SET CMBN=1
+2 SET PGM=$SELECT($DATA(^DVB(396.6,JY,0)):$PIECE(^(0),U,4),1:"")
+3 IF PGM=""
QUIT
+4 SET TNAM=$PIECE(^(0),U,1)
SET PGM="^"_PGM
DO @PGM
+5 NEW DVBCEXM
SET DVBCEXM=EXMNM
KILL DVBCFF
+6 IF ZC="A"
Begin DoDot:1
+7 SET DVBCEXM=$ORDER(TEMP("NEW","A",DVBCEXM))
+8 IF DVBCEXM'=""
SET DVBCFF=""
+9 IF '$DATA(DVBCFF)
SET DVBCEXM=$ORDER(TEMP("NEW","Z",""))
Begin DoDot:2
+10 IF DVBCEXM'=""
SET DVBCFF=""
End DoDot:2
End DoDot:1
+11 IF ZC="Z"
Begin DoDot:1
+12 SET DVBCEXM=$ORDER(TEMP("NEW","Z",DVBCEXM))
+13 IF DVBCEXM'=""
SET DVBCFF=""
End DoDot:1
+14 if (IOST?1"P-".E)&($DATA(DVBCFF))
WRITE @IOF
+15 KILL DVBCFF,DVBCEXM
+16 SET $PIECE(^DVB(396.4,EXDA,0),U,5)="Y"
+17 KILL CMBN,TNAM,PGM
QUIT
+18 ;
EN WRITE @FF,!!,"Worksheets should be sent to a printer."
SET %ZIS="AEQ"
SET %ZIS("A")="Output device: "
DO ^%ZIS
if POP
QUIT
KILL %ZIS
+1 ;
QUE IF $DATA(IO("Q"))
SET ZTRTN=$SELECT($DATA(RPRT):"GO2^DVBCADE1",1:"GO^DVBCADE1")
SET ZTDESC="Print C&P Work Sheets"
FOR I="DUZ","DA*","DFN","TEMP*","REQDA","OWNDOM","RPRT","C*","SSN","PNAM"
SET ZTSAVE(I)=""
+1 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if '$DATA(ZTSK)
SET POP=1
if $DATA(ZTSK)
WRITE !!,"Request queued",!!
HANG 1
KILL IO("Q"),ZTRTN,ZTIO,ZTDESC
if '$DATA(RPRT)
KILL ZTSK
QUIT
+2 if $DATA(RPRT)
QUIT
+3 ;
GO USE IO
SET DA=REQDA
DO VARS^DVBCUTIL
+1 SET EXMNM=""
FOR ZC="A","Z"
FOR JZ=0:0
SET EXMNM=$ORDER(TEMP("NEW",ZC,EXMNM))
if EXMNM=""
QUIT
SET JY=$PIECE(TEMP("NEW",ZC,EXMNM),U,1)
SET EXDA=$PIECE(TEMP("NEW",ZC,EXMNM),U,3)
DO CK1
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
QUIT
+3 ;
SET SET EXDA=+Y
SET JY=$PIECE(Y,U,2)
DO EXMNM
IF '$DATA(OUT)
DO FMT
if $DATA(OUT)
DO QUES
if $DATA(OUT)
QUIT
IF '$DATA(OUT)
SET ^TMP($JOB,"NEW",EXMNM)=JY_U_FMT_U_EXDA
HANG 1
WRITE @FF,!!,HD4,!!!
+1 QUIT
+2 ;
+3 ;print/reprint worksheets
RPRT SET RPRT=1
DO HOME^%ZIS
SET FF=IOF
+1 ;
EN1 KILL ^TMP($JOB),DA,EXDA,EXMNM,OUT,DIC
+1 WRITE @FF,!,"Print/Reprint C&P Worksheets",!!!
+2 SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
SET DIC("A")="Select VETERAN NAME: "
+3 DO ^DIC
if X=""!(X=U)
GOTO EXIT
SET (REQDA,DA(1))=+Y
+4 SET HD4="Select exam(s) to print or enter ALL to print all exams."
+5 WRITE !!,HD4,!!!
+6 KILL OUT,OUT1
+7 FOR I=0:0
KILL DIC,Y,D
SET DIC("A")="Select EXAM: "
WRITE ?10,DIC("A")
SET DIC="^DVB(396.6,"
SET DIC("S")="I $D(^DVB(396.4,""ARQ""_REQDA,+Y))"
SET DIC(0)="EQ"
READ X:DTIME
if '$TEST
SET OUT1=1
if $DATA(OUT1)!(X="")!(X=U)!(X="ALL")!(X="all")
QUIT
Begin DoDot:1
+8 DO ^DIC
if X["?"
DO QUES
if +Y<0
WRITE !!
+9 IF +Y>0
KILL DIC
SET X=+Y
SET DIC="^DVB(396.4,"
SET DIC(0)="EQ"
SET D="ARQ"_REQDA
Begin DoDot:2
+10 DO MIX^DIC1
KILL DIC,D
End DoDot:2
+11 IF +Y>0
DO SET
End DoDot:1
+12 if $DATA(OUT1)
GOTO EXIT
+13 IF $DATA(X)
IF X="ALL"!(X="all")
FOR EXDA=0:0
SET EXDA=$ORDER(^DVB(396.4,"C",REQDA,EXDA))
if EXDA=""
QUIT
DO FMT
if $DATA(OUT1)
GOTO EXIT
if $DATA(OUT)
QUIT
SET ^TMP($JOB,"NEW",EXMNM)=JY_U_FMT_U_EXDA
+14 IF '$DATA(^TMP($JOB,"NEW"))
WRITE *7,!!,"No exams selected ..."
HANG 2
GOTO EN1
+15 DO COPY
DO EN
if POP
GOTO EXIT
IF $DATA(ZTSK)
KILL ZTSK
GOTO EN1
+16 ;
GO2 USE IO
SET DA=DA(1)
DO VARS^DVBCUTIL
+1 SET OWNDOM=$PIECE(^DVB(396.3,DA(1),0),U,22)
IF OWNDOM]""
DO ^DVBCTRNN
+2 SET EXMNM=""
FOR ZC="A","Z"
FOR JZ=0:0
SET EXMNM=$ORDER(TEMP("NEW",ZC,EXMNM))
if EXMNM=""
QUIT
SET JY=$PIECE(TEMP("NEW",ZC,EXMNM),U,1)
SET EXDA=$PIECE(TEMP("NEW",ZC,EXMNM),U,3)
DO CK1
+3 DO ^%ZISC
if '$DATA(ZTQUEUED)
GOTO EN1
IF $DATA(ZTQUEUED)
GOTO EXIT
+4 ;
EXMNM KILL OUT
SET JY=$PIECE(^DVB(396.4,EXDA,0),U,3)
+1 SET EXMNM=$SELECT($DATA(^DVB(396.6,JY,0)):$PIECE(^(0),U,1),1:"")
+2 ;!($D(^TMP($J,"NEW",EXMNM))) S OUT=1
IF EXMNM=""
SET OUT=1
+3 QUIT
+4 ;
FMT WRITE @IOF,!
DO EXMNM
WRITE !!?10,EXMNM,!
+1 KILL OUT,OUT1
IF $PIECE(^DVB(396.4,EXDA,0),U,4)'="O"
WRITE *7,!!?5,"Status is not OPEN - No worksheet will be printed. "
HANG 3
SET OUT=1
QUIT
+2 SET FMT="F"
+3 QUIT
+4 ;
COPY ;full come out first
KILL TEMP
SET X=""
FOR Y=0:0
SET X=$ORDER(^TMP($JOB,"NEW",X))
if X=""
QUIT
SET Z=$SELECT($PIECE(^TMP($JOB,"NEW",X),U,2)="F":"A",1:"Z")
SET TEMP("NEW",Z,X)=^TMP($JOB,"NEW",X)
+1 QUIT
+2 ;
QUES WRITE !!,"Press RETURN to continue "
READ ANS:DTIME
+1 WRITE @FF,!!,HD4,!!!
+2 QUIT
+3 ;
EXIT KILL RPRT,FMT,OUT,OUT1
if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBCUTIL
