- 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 Mar 13, 2025@20:53:12 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
