DVBCREQP ;ALB/GTS-557/THM-PRINT NEW REQUESTS ; 6/27/91 9:36 AM
;;2.7;AMIE;**193**;;Build 84
S DVBAMAN="" G EN
;
CK1 F JI=BDTRQ-.1:0 S JI=$O(^DVB(396.3,XD,JI)) Q:JI="" F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,XD,JI,DA(1))) Q:DA(1)="" S DVBXD=$S($D(^DVB(396.3,DA(1),1)):$P(^(1),U,4),1:"") I DVBXD=XDIV S FIND=1
Q
;
PRINT K OUT S STAT=$P(^DVB(396.3,DA(1),0),U,18) ;I STAT["X" S OUT=1 Q
;AJF ; Request Status; 012417
S STAT=$$RSTAT^DVBCUTL8(STAT)
S DVBCDIV=$S($D(^DVB(396.3,DA(1),1)):$P(^(1),U,4),1:"") Q:DVBCDIV'=XDIV
S DA=DA(1) D VARS^DVBCUTIL,^DVBCREQ1
S:CNUM="" CNUM=99999999 S:SSN="" SSN=999999999 S:PNAM="" PNAM="Missing vet name"
S DA=DA(1),DIE="^DVB(396.3,",DR="17////2"
I STAT="N"!(STAT="NT") D ^DIE
;AJF ; Reroute request; 072016
I STAT="NR" S DA=DA(1),DIE="^DVB(396.3,",DR="17////14" D ^DIE
SET S DA=DA(1),DR="4///NOW",(DIC,DIE)="^DVB(396.3,"
I $P(^DVB(396.3,DA,0),U,5)="" D ^DIE
I '$D(ONE) S ^TMP($J,DVBCTYPE,PNAM,SSN,CNUM)="" ;for last sheet
S (PNAM,SSN,CNUM,ADR1,ADR2,ADR3,CITY,STATE,ZIP,HOMPHON,BUSPHON,OTHDIS)="",PRINT=1
Q
;
EN K PRINT S Y=DT X ^DD("DD") S DVBCDT(0)=Y D HOME^%ZIS S FF=IOF W @FF,"Manual New C&P Request Printing",!!!
;
ASK K ONE W !,"Do you want just one request" S %=2 D YN^DICN G:$D(DTOUT) EXIT I $D(%Y),%Y["?" W !,"Enter Y for only one Vet or N for all Vets.",! G ASK
G:%Y=U EXIT I %=1 G ONEREQ
W ! D DIV I $D(OUT) K OUT G EXIT
W ! S %DT(0)=-DT,%DT="AET",%DT("A")="Enter BEGINNING date of request: " D ^%DT G:Y<0 EXIT S BDTRQ=Y,%DT="AET",%DT("A")=" and ENDING date of request: " D ^%DT G:Y<0 EN S EDTRQ=Y+.2359
I EDTRQ<BDTRQ W !!,*7,"Ending date is earlier than starting date!",!! H 2 G EN
;
DEVICE K %DT W !! S %ZIS="AEQ",%ZIS("A")="Output device: " D ^%ZIS K %ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN=$S($D(ONE):"PRINT^DVBCREQP",1:"GO^DVBCREQP"),ZTIO=ION,ZTDESC="New C&P request printing" F I="ONE","BDTRQ*","EDTRQ*","DA*","Y","XDIV","DIVNM","DVBCDT(0)","DVBCMAN" S ZTSAVE(I)=""
I $D(IO("Q")) D ^%ZTLOAD G:'$D(ZTSK) EXIT W !!,"Request queued",!! G EXIT
I $D(ONE) U IO D PRINT K DA G EXIT
;
GO D STM^DVBCUTL4
U IO S X="New C&P Requests -- "_DIVNM
W:(IOST?1"C-".E) @IOF
W !!!!!!!!!!!!!!! F I=1:1:10 W ?5,X,!!
K ^TMP($J),X,PRINT S DVBCTYPE="NEW"
F JI=BDTRQ_".0001":0 S JI=$O(^DVB(396.3,"C",JI)) Q:JI=""!(JI>EDTRQ) F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"C",JI,DA(1))) Q:DA(1)="" K OUT D PRINT
K OUT I '$D(PRINT) W @IOF,!!!,"There were no new 2507 requests for " S Y=BDTRQ X ^DD("DD") W Y," to " S Y=$E(EDTRQ,1,7) X ^DD("DD") W Y,!,"for division ",DIVNM,!!
MODS K FIND S XD="AC" D CK1 I '$D(FIND) G ADDS
K PRINT,FIND S X="C&P Request Modifications -- "_DIVNM W @IOF,!!!!!!!!!!!!!!! F I=1:1:10 W ?5,X,!!
K X S DVBCTYPE="MODIFIED"
F JI=BDTRQ_".0001":0 S JI=$O(^DVB(396.3,"AC",JI)) Q:JI=""!(JI>EDTRQ) F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AC",JI,DA(1))) Q:DA(1)="" K OUT D PRINT
I '$D(PRINT) W @IOF,!!!,"No modified requests to report.",!!
;
ADDS K FIND S XD="AD" D CK1 I '$D(FIND) G REROUTE
K PRINT,FIND S X="C&P Exams Added -- "_DIVNM W @IOF,!!!!!!!!!!!!!!! F I=1:1:10 W ?5,X,!!
K X S DVBCTYPE="ADDITIONAL"
F JI=BDTRQ_".0001":0 S JI=$O(^DVB(396.3,"AD",JI)) Q:JI=""!(JI>EDTRQ) F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AD",JI,DA(1))) Q:DA(1)="" K OUT D PRINT
I '$D(PRINT) W @IOF,!!!,"No added exams to report.",!!
;
REROUTE K FIND S XD="AR" D CK1 I '$D(FIND) G RECAP
K PRINT,FIND S X="C&P Request Rerouted -- "_DIVNM W @IOF,!!!!!!!!!!!!!!! F I=1:1:10 W ?5,X,!!
K X S DVBCTYPE="REROUTED",CSITE=$P($$SITE^VASITE,"^",3)
F JI=BDTRQ_".0001":0 S JI=$O(^DVB(396.3,"AR",JI)) Q:JI=""!(JI>EDTRQ) D
.F DA(1)=0:0 S DA(1)=$O(^DVB(396.3,"AR",JI,DA(1))) Q:DA(1)="" D
..S R1=$O(^DVB(396.3,DA(1),6,99999),-1),R2=$O(^DVB(396.3,DA(1),6,R1,1,99999),-1)
..S RRQST=$P($G(^DVB(396.3,DA(1),6,R1,1,R2,0)),"^",2)
..Q:CSITE=$P(^DVB(396.3,DA(1),6,1,2),"^",4)&(RRQST'="R")
..K OUT D PRINT
I '$D(PRINT) W @IOF,!!!,"No Rerouted request to report.",!!
;
RECAP D ^DVBCREQ3 ;recap sheet
;
EXIT S XRTN=$T(+0)
D SPM^DVBCUTL4
I $D(DVBCMAN)&($D(ZTQUEUED)) D KILL^%ZTLOAD
K DVBCMAN,DIVNM,XDIV,DVBXD G KILL^DVBCUTIL
;
;
ONEREQ W !! S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("W")="W !?10,""Date of request: "" S:$D(Y) OLDY=Y S Y=$P(^(0),U,2) X ^DD(""DD"") W Y S:$D(OLDY) Y=OLDY",DIC("A")="Enter VETERAN NAME: " D ^DIC G:X=""!(X=U) EXIT
S JI=$P(Y,U,2),DA(1)=+Y D DIV I $D(OUT) G EXIT
S ONE=1 G DEVICE
;
TASK D ^DVBCREQ2 Q
;
DIV W !! K OUT S DIC("A")="Enter MED CENTER DIVISION: ",DIC(0)="AEQM",DIC="^DG(40.8," D ^DIC I X=""!(X=U) S OUT=1 Q
I +Y<0 W *7," ???" G DIV
S XDIV=+Y,DIVNM=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown Division") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCREQP 4665 printed Oct 16, 2024@17:49:21 Page 2
DVBCREQP ;ALB/GTS-557/THM-PRINT NEW REQUESTS ; 6/27/91 9:36 AM
+1 ;;2.7;AMIE;**193**;;Build 84
+2 SET DVBAMAN=""
GOTO EN
+3 ;
CK1 FOR JI=BDTRQ-.1:0
SET JI=$ORDER(^DVB(396.3,XD,JI))
if JI=""
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,XD,JI,DA(1)))
if DA(1)=""
QUIT
SET DVBXD=$SELECT($DATA(^DVB(396.3,DA(1),1)):$PIECE(^(1),U,4),1:"")
IF DVBXD=XDIV
SET FIND=1
+1 QUIT
+2 ;
PRINT ;I STAT["X" S OUT=1 Q
KILL OUT
SET STAT=$PIECE(^DVB(396.3,DA(1),0),U,18)
+1 ;AJF ; Request Status; 012417
+2 SET STAT=$$RSTAT^DVBCUTL8(STAT)
+3 SET DVBCDIV=$SELECT($DATA(^DVB(396.3,DA(1),1)):$PIECE(^(1),U,4),1:"")
if DVBCDIV'=XDIV
QUIT
+4 SET DA=DA(1)
DO VARS^DVBCUTIL
DO ^DVBCREQ1
+5 if CNUM=""
SET CNUM=99999999
if SSN=""
SET SSN=999999999
if PNAM=""
SET PNAM="Missing vet name"
+6 SET DA=DA(1)
SET DIE="^DVB(396.3,"
SET DR="17////2"
+7 IF STAT="N"!(STAT="NT")
DO ^DIE
+8 ;AJF ; Reroute request; 072016
+9 IF STAT="NR"
SET DA=DA(1)
SET DIE="^DVB(396.3,"
SET DR="17////14"
DO ^DIE
SET SET DA=DA(1)
SET DR="4///NOW"
SET (DIC,DIE)="^DVB(396.3,"
+1 IF $PIECE(^DVB(396.3,DA,0),U,5)=""
DO ^DIE
+2 ;for last sheet
IF '$DATA(ONE)
SET ^TMP($JOB,DVBCTYPE,PNAM,SSN,CNUM)=""
+3 SET (PNAM,SSN,CNUM,ADR1,ADR2,ADR3,CITY,STATE,ZIP,HOMPHON,BUSPHON,OTHDIS)=""
SET PRINT=1
+4 QUIT
+5 ;
EN KILL PRINT
SET Y=DT
XECUTE ^DD("DD")
SET DVBCDT(0)=Y
DO HOME^%ZIS
SET FF=IOF
WRITE @FF,"Manual New C&P Request Printing",!!!
+1 ;
ASK KILL ONE
WRITE !,"Do you want just one request"
SET %=2
DO YN^DICN
if $DATA(DTOUT)
GOTO EXIT
IF $DATA(%Y)
IF %Y["?"
WRITE !,"Enter Y for only one Vet or N for all Vets.",!
GOTO ASK
+1 if %Y=U
GOTO EXIT
IF %=1
GOTO ONEREQ
+2 WRITE !
DO DIV
IF $DATA(OUT)
KILL OUT
GOTO EXIT
+3 WRITE !
SET %DT(0)=-DT
SET %DT="AET"
SET %DT("A")="Enter BEGINNING date of request: "
DO ^%DT
if Y<0
GOTO EXIT
SET BDTRQ=Y
SET %DT="AET"
SET %DT("A")=" and ENDING date of request: "
DO ^%DT
if Y<0
GOTO EN
SET EDTRQ=Y+.2359
+4 IF EDTRQ<BDTRQ
WRITE !!,*7,"Ending date is earlier than starting date!",!!
HANG 2
GOTO EN
+5 ;
DEVICE KILL %DT
WRITE !!
SET %ZIS="AEQ"
SET %ZIS("A")="Output device: "
DO ^%ZIS
KILL %ZIS
if POP
GOTO EXIT
+1 IF $DATA(IO("Q"))
SET ZTRTN=$SELECT($DATA(ONE):"PRINT^DVBCREQP",1:"GO^DVBCREQP")
SET ZTIO=ION
SET ZTDESC="New C&P request printing"
FOR I="ONE","BDTRQ*","EDTRQ*","DA*","Y","XDIV","DIVNM","DVBCDT(0)","DVBCMAN"
SET ZTSAVE(I)=""
+2 IF $DATA(IO("Q"))
DO ^%ZTLOAD
if '$DATA(ZTSK)
GOTO EXIT
WRITE !!,"Request queued",!!
GOTO EXIT
+3 IF $DATA(ONE)
USE IO
DO PRINT
KILL DA
GOTO EXIT
+4 ;
GO DO STM^DVBCUTL4
+1 USE IO
SET X="New C&P Requests -- "_DIVNM
+2 if (IOST?1"C-".E)
WRITE @IOF
+3 WRITE !!!!!!!!!!!!!!!
FOR I=1:1:10
WRITE ?5,X,!!
+4 KILL ^TMP($JOB),X,PRINT
SET DVBCTYPE="NEW"
+5 FOR JI=BDTRQ_".0001":0
SET JI=$ORDER(^DVB(396.3,"C",JI))
if JI=""!(JI>EDTRQ)
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"C",JI,DA(1)))
if DA(1)=""
QUIT
KILL OUT
DO PRINT
+6 KILL OUT
IF '$DATA(PRINT)
WRITE @IOF,!!!,"There were no new 2507 requests for "
SET Y=BDTRQ
XECUTE ^DD("DD")
WRITE Y," to "
SET Y=$EXTRACT(EDTRQ,1,7)
XECUTE ^DD("DD")
WRITE Y,!,"for division ",DIVNM,!!
MODS KILL FIND
SET XD="AC"
DO CK1
IF '$DATA(FIND)
GOTO ADDS
+1 KILL PRINT,FIND
SET X="C&P Request Modifications -- "_DIVNM
WRITE @IOF,!!!!!!!!!!!!!!!
FOR I=1:1:10
WRITE ?5,X,!!
+2 KILL X
SET DVBCTYPE="MODIFIED"
+3 FOR JI=BDTRQ_".0001":0
SET JI=$ORDER(^DVB(396.3,"AC",JI))
if JI=""!(JI>EDTRQ)
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AC",JI,DA(1)))
if DA(1)=""
QUIT
KILL OUT
DO PRINT
+4 IF '$DATA(PRINT)
WRITE @IOF,!!!,"No modified requests to report.",!!
+5 ;
ADDS KILL FIND
SET XD="AD"
DO CK1
IF '$DATA(FIND)
GOTO REROUTE
+1 KILL PRINT,FIND
SET X="C&P Exams Added -- "_DIVNM
WRITE @IOF,!!!!!!!!!!!!!!!
FOR I=1:1:10
WRITE ?5,X,!!
+2 KILL X
SET DVBCTYPE="ADDITIONAL"
+3 FOR JI=BDTRQ_".0001":0
SET JI=$ORDER(^DVB(396.3,"AD",JI))
if JI=""!(JI>EDTRQ)
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AD",JI,DA(1)))
if DA(1)=""
QUIT
KILL OUT
DO PRINT
+4 IF '$DATA(PRINT)
WRITE @IOF,!!!,"No added exams to report.",!!
+5 ;
REROUTE KILL FIND
SET XD="AR"
DO CK1
IF '$DATA(FIND)
GOTO RECAP
+1 KILL PRINT,FIND
SET X="C&P Request Rerouted -- "_DIVNM
WRITE @IOF,!!!!!!!!!!!!!!!
FOR I=1:1:10
WRITE ?5,X,!!
+2 KILL X
SET DVBCTYPE="REROUTED"
SET CSITE=$PIECE($$SITE^VASITE,"^",3)
+3 FOR JI=BDTRQ_".0001":0
SET JI=$ORDER(^DVB(396.3,"AR",JI))
if JI=""!(JI>EDTRQ)
QUIT
Begin DoDot:1
+4 FOR DA(1)=0:0
SET DA(1)=$ORDER(^DVB(396.3,"AR",JI,DA(1)))
if DA(1)=""
QUIT
Begin DoDot:2
+5 SET R1=$ORDER(^DVB(396.3,DA(1),6,99999),-1)
SET R2=$ORDER(^DVB(396.3,DA(1),6,R1,1,99999),-1)
+6 SET RRQST=$PIECE($GET(^DVB(396.3,DA(1),6,R1,1,R2,0)),"^",2)
+7 if CSITE=$PIECE(^DVB(396.3,DA(1),6,1,2),"^",4)&(RRQST'="R")
QUIT
+8 KILL OUT
DO PRINT
End DoDot:2
End DoDot:1
+9 IF '$DATA(PRINT)
WRITE @IOF,!!!,"No Rerouted request to report.",!!
+10 ;
RECAP ;recap sheet
DO ^DVBCREQ3
+1 ;
EXIT SET XRTN=$TEXT(+0)
+1 DO SPM^DVBCUTL4
+2 IF $DATA(DVBCMAN)&($DATA(ZTQUEUED))
DO KILL^%ZTLOAD
+3 KILL DVBCMAN,DIVNM,XDIV,DVBXD
GOTO KILL^DVBCUTIL
+4 ;
+5 ;
ONEREQ WRITE !!
SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
SET DIC("W")="W !?10,""Date of request: "" S:$D(Y) OLDY=Y S Y=$P(^(0),U,2) X ^DD(""DD"") W Y S:$D(OLDY) Y=OLDY"
SET DIC("A")="Enter VETERAN NAME: "
DO ^DIC
if X=""!(X=U)
GOTO EXIT
+1 SET JI=$PIECE(Y,U,2)
SET DA(1)=+Y
DO DIV
IF $DATA(OUT)
GOTO EXIT
+2 SET ONE=1
GOTO DEVICE
+3 ;
TASK DO ^DVBCREQ2
QUIT
+1 ;
DIV WRITE !!
KILL OUT
SET DIC("A")="Enter MED CENTER DIVISION: "
SET DIC(0)="AEQM"
SET DIC="^DG(40.8,"
DO ^DIC
IF X=""!(X=U)
SET OUT=1
QUIT
+1 IF +Y<0
WRITE *7," ???"
GOTO DIV
+2 SET XDIV=+Y
SET DIVNM=$SELECT($DATA(^DG(40.8,XDIV,0)):$PIECE(^(0),U,1),1:"Unknown Division")
QUIT
