- 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 Mar 13, 2025@20:48:01 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
