DVBCENQ ;ALB/GTS-557/THM-2507 INQUIRY ; 1/3/23 12:33pm
;;2.7;AMIE;**209,212,220,243**;Apr 10, 1995;Build 13
;
; Per VHA Directive 6402 this routine should not be modified
; Reference to GET^XPAR in ICR #2263
; Reference to OWNSKEY^XUSER in ICR #3277
; Reference to UP^XLFSTR in ICR #10104
;
G EN
PRINT D VARS^DVBCUTIL,^DVBCENQ1
I $D(ZTQUEUED) G EXIT ;entry point for TaskMan
S (NAME,SSN,CNUM,ADR1,ADR2,ADR3,CITY,STATE,ZIP,HOMPHON,BUSPHON,OTHDIS)=""
Q
;
EN K ^TMP($J) S Y=DT X ^DD("DD") S FDT(0)=Y D HOME^%ZIS S FF=IOF
W @FF,"2507 Request Inquiry",!!!
S DIC="^DVB(396.3,",DIC(0)="AEQM",DIC("W")="W "" Date of request: "" S DVBCDT=$P(^(0),U,2) W $E(DVBCDT,4,5)_""/""_$E(DVBCDT,6,7)_""/""_$E(DVBCDT,2,3)",DIC("A")="Enter VETERAN NAME: " D ^DIC G:X=""!(X=U) EXIT
I +Y<0 W " ???",*7 G EN
S JI=$P(Y,U,2),(DA,DA(1),REQDA)=+Y
;
DEVICE W ! S %ZIS="AEQ",%ZIS("B")="HOME",%ZIS("A")="Output device: " D ^%ZIS G:POP EXIT
I $D(IO("Q")) S ZTRTN="PRINT^DVBCENQ",ZTIO=ION,ZTDESC="C&P Request Inquiry" F I="FDT(0)","DA*","REQDA","DVBC*","Y","JI","DUZ","FDT(0)" S ZTSAVE(I)=""
I D ^%ZTLOAD G:'$D(ZTSK) EXIT W !!,"Request queued",!! G EXIT
U IO D PRINT D ^%ZISC G EN
;
EXIT K ^TMP($J),TSTA1,TSTAT,XCNP
D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
;
EDIPIQ(Y,DFN) ;
K Y,DVEDIPI S Y=""
I '$D(DFN) S Y=0 Q
S DVBED="" F S DVBED=$O(^DGCN(391.91,"B",DFN,DVBED)) D Q:DVBED=""
.Q:DVBED=""
.I $P($G(^DGCN(391.91,DVBED,2)),U)'["DOD" Q
.S DVEDIPI=$P(^DGCN(391.91,DVBED,2),U,2)
S Y=$G(DVEDIPI) I Y="" S Y=0
Q
EDIPIQ2(DVBRTN,DFN) ;
K DVBRTN,DVEDIPI S DVBRTN=""
N DVBED,DVBBOS,DVEDIPI,VASV
I $G(DFN)="" S DVBRTN=0 Q
S DVBED="" F S DVBED=$O(^DGCN(391.91,"B",DFN,DVBED)) D Q:DVBED=""
.Q:DVBED=""
.I $P($G(^DGCN(391.91,DVBED,2)),U)'["DOD" Q
.S DVEDIPI=$P(^DGCN(391.91,DVBED,2),U,2)
S DVBRTN=$G(DVEDIPI) I DVBRTN="" S DVBRTN=0
D SVC^VADPT
S DVBBOS=$P($G(VASV(6,1)),U,2) I DVBBOS="" S DVBBOS=0
S DVBRTN=$G(DVBRTN)_"^"_$G(DVBBOS)
D KVAR^VADPT
Q
SELFREF(DVBDBQ,DFN) ;
K DVBDBQ S DVBDBQ=""
N DVBED,DVBSF,DVBDT,X1,X2,X,CNT,DVBYR,DVBYEAR
I $G(DFN)="" S DVBDBQ=0 Q
S CNT=0
S DVBDT="" F S DVBDT=$O(^DVB(396.17,"C",DVBDT),-1) D Q:DVBDT=""
.S X1=DT,X2=DVBDT,DVBYR=365
.S DVBYEAR=+$E(DT,1,3)+1700 I $$LEAPYEAR(DVBYEAR) S DVBYR=366
.D ^%DTC I X>DVBYR Q
.Q:DVBDT=""
.S DVBED="" F S DVBED=$O(^DVB(396.17,"C",DVBDT,DVBED)) D Q:DVBED=""
..S DVBDFN=$$GET1^DIQ(396.17,DVBED,".01","I") I DVBDFN'=DFN Q
..S DVBSF=$$GET1^DIQ(396.17,DVBED,"25","I") Q:DVBSF'="Y"
..S CNT=CNT+1 S DVBDBQ(CNT)=$$FMTE^XLFDT(DVBDT,"5D")_" "_$$GET1^DIQ(396.17,DVBED,"9","I")
..Q
Q
LEAPYEAR(YEAR) ;
N RETVAL S RETVAL=0
I YEAR#400=0 S RETVAL=1
I YEAR#100=0 S RETVAL=0
I YEAR#4=0 S RETVAL=1
Q RETVAL
EFOLDER(DVBRTN,DFN) ;
;return is 0, 1 or -1
K DVBRTN S DVBRTN=""
I $G(DFN)="" S DVBRTN="-1^MISSING DFN" Q
N DVBVBA,DVBTIT,DVBLIST,DVNCT,DVBTT
S DVBRTN=0
S DVBVBA=$$GET1^DIQ(200,DFN,29)
S DVBVBA=$$UP^XLFSTR(DVBVBA)
I $G(DVBVBA)["VBA" S DVBRTN=1 Q
S DVBTIT=$$GET1^DIQ(200,DFN,8) D
.I $G(DVBTIT)="" Q
.S DVBTIT=$$UP^XLFSTR(DVBTIT)
.S DVBLIST=$$GET^XPAR("PKG","DVBAB CAPRI VHA TITLE",1,"Q")
.I $D(DVBLIST) D
..S DVNCT=0
..F S DVNCT=DVNCT+1 S DVBTT=$P(DVBLIST,"*",DVNCT) Q:DVBTT="" D
...I DVBTT[DVBTIT S DVBRTN=1 Q
..Q
Q
LOCATION(DVBRTN) ;
K DVBRTN S DVBRTN=""
S DVBRTN=$$GET^XPAR("PKG","DVBAB CAPRI EFOLDER LOCATION",1,"Q")
Q
PROVIDER(DVBRTN,DFN) ;
K DVBRTN S DVBRTN=0
N DVBPROV,DVBPROV2
S DVBPROV="" D OWNSKEY^XUSRB(.DVBPROV,"PROVIDER",DFN) I $G(DVBPROV(0))=1 S DVBRTN=1 Q
S DVBPROV2="" D OWNSKEY^XUSRB(.DVBPROV2,"XUORES",DFN) I $G(DVBPROV2(0))=1 S DVBRTN=1 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCENQ 3681 printed Dec 13, 2024@01:44:01 Page 2
DVBCENQ ;ALB/GTS-557/THM-2507 INQUIRY ; 1/3/23 12:33pm
+1 ;;2.7;AMIE;**209,212,220,243**;Apr 10, 1995;Build 13
+2 ;
+3 ; Per VHA Directive 6402 this routine should not be modified
+4 ; Reference to GET^XPAR in ICR #2263
+5 ; Reference to OWNSKEY^XUSER in ICR #3277
+6 ; Reference to UP^XLFSTR in ICR #10104
+7 ;
+8 GOTO EN
PRINT DO VARS^DVBCUTIL
DO ^DVBCENQ1
+1 ;entry point for TaskMan
IF $DATA(ZTQUEUED)
GOTO EXIT
+2 SET (NAME,SSN,CNUM,ADR1,ADR2,ADR3,CITY,STATE,ZIP,HOMPHON,BUSPHON,OTHDIS)=""
+3 QUIT
+4 ;
EN KILL ^TMP($JOB)
SET Y=DT
XECUTE ^DD("DD")
SET FDT(0)=Y
DO HOME^%ZIS
SET FF=IOF
+1 WRITE @FF,"2507 Request Inquiry",!!!
+2 SET DIC="^DVB(396.3,"
SET DIC(0)="AEQM"
SET DIC("W")="W "" Date of request: "" S DVBCDT=$P(^(0),U,2) W $E(DVBCDT,4,5)_""/""_$E(DVBCDT,6,7)_""/""_$E(DVBCDT,2,3)"
SET DIC("A")="Enter VETERAN NAME: "
DO ^DIC
if X=""!(X=U)
GOTO EXIT
+3 IF +Y<0
WRITE " ???",*7
GOTO EN
+4 SET JI=$PIECE(Y,U,2)
SET (DA,DA(1),REQDA)=+Y
+5 ;
DEVICE WRITE !
SET %ZIS="AEQ"
SET %ZIS("B")="HOME"
SET %ZIS("A")="Output device: "
DO ^%ZIS
if POP
GOTO EXIT
+1 IF $DATA(IO("Q"))
SET ZTRTN="PRINT^DVBCENQ"
SET ZTIO=ION
SET ZTDESC="C&P Request Inquiry"
FOR I="FDT(0)","DA*","REQDA","DVBC*","Y","JI","DUZ","FDT(0)"
SET ZTSAVE(I)=""
+2 IF $TEST
DO ^%ZTLOAD
if '$DATA(ZTSK)
GOTO EXIT
WRITE !!,"Request queued",!!
GOTO EXIT
+3 USE IO
DO PRINT
DO ^%ZISC
GOTO EN
+4 ;
EXIT KILL ^TMP($JOB),TSTA1,TSTAT,XCNP
+1 if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
GOTO KILL^DVBCUTIL
+2 ;
EDIPIQ(Y,DFN) ;
+1 KILL Y,DVEDIPI
SET Y=""
+2 IF '$DATA(DFN)
SET Y=0
QUIT
+3 SET DVBED=""
FOR
SET DVBED=$ORDER(^DGCN(391.91,"B",DFN,DVBED))
Begin DoDot:1
+4 if DVBED=""
QUIT
+5 IF $PIECE($GET(^DGCN(391.91,DVBED,2)),U)'["DOD"
QUIT
+6 SET DVEDIPI=$PIECE(^DGCN(391.91,DVBED,2),U,2)
End DoDot:1
if DVBED=""
QUIT
+7 SET Y=$GET(DVEDIPI)
IF Y=""
SET Y=0
+8 QUIT
EDIPIQ2(DVBRTN,DFN) ;
+1 KILL DVBRTN,DVEDIPI
SET DVBRTN=""
+2 NEW DVBED,DVBBOS,DVEDIPI,VASV
+3 IF $GET(DFN)=""
SET DVBRTN=0
QUIT
+4 SET DVBED=""
FOR
SET DVBED=$ORDER(^DGCN(391.91,"B",DFN,DVBED))
Begin DoDot:1
+5 if DVBED=""
QUIT
+6 IF $PIECE($GET(^DGCN(391.91,DVBED,2)),U)'["DOD"
QUIT
+7 SET DVEDIPI=$PIECE(^DGCN(391.91,DVBED,2),U,2)
End DoDot:1
if DVBED=""
QUIT
+8 SET DVBRTN=$GET(DVEDIPI)
IF DVBRTN=""
SET DVBRTN=0
+9 DO SVC^VADPT
+10 SET DVBBOS=$PIECE($GET(VASV(6,1)),U,2)
IF DVBBOS=""
SET DVBBOS=0
+11 SET DVBRTN=$GET(DVBRTN)_"^"_$GET(DVBBOS)
+12 DO KVAR^VADPT
+13 QUIT
SELFREF(DVBDBQ,DFN) ;
+1 KILL DVBDBQ
SET DVBDBQ=""
+2 NEW DVBED,DVBSF,DVBDT,X1,X2,X,CNT,DVBYR,DVBYEAR
+3 IF $GET(DFN)=""
SET DVBDBQ=0
QUIT
+4 SET CNT=0
+5 SET DVBDT=""
FOR
SET DVBDT=$ORDER(^DVB(396.17,"C",DVBDT),-1)
Begin DoDot:1
+6 SET X1=DT
SET X2=DVBDT
SET DVBYR=365
+7 SET DVBYEAR=+$EXTRACT(DT,1,3)+1700
IF $$LEAPYEAR(DVBYEAR)
SET DVBYR=366
+8 DO ^%DTC
IF X>DVBYR
QUIT
+9 if DVBDT=""
QUIT
+10 SET DVBED=""
FOR
SET DVBED=$ORDER(^DVB(396.17,"C",DVBDT,DVBED))
Begin DoDot:2
+11 SET DVBDFN=$$GET1^DIQ(396.17,DVBED,".01","I")
IF DVBDFN'=DFN
QUIT
+12 SET DVBSF=$$GET1^DIQ(396.17,DVBED,"25","I")
if DVBSF'="Y"
QUIT
+13 SET CNT=CNT+1
SET DVBDBQ(CNT)=$$FMTE^XLFDT(DVBDT,"5D")_" "_$$GET1^DIQ(396.17,DVBED,"9","I")
+14 QUIT
End DoDot:2
if DVBED=""
QUIT
End DoDot:1
if DVBDT=""
QUIT
+15 QUIT
LEAPYEAR(YEAR) ;
+1 NEW RETVAL
SET RETVAL=0
+2 IF YEAR#400=0
SET RETVAL=1
+3 IF YEAR#100=0
SET RETVAL=0
+4 IF YEAR#4=0
SET RETVAL=1
+5 QUIT RETVAL
EFOLDER(DVBRTN,DFN) ;
+1 ;return is 0, 1 or -1
+2 KILL DVBRTN
SET DVBRTN=""
+3 IF $GET(DFN)=""
SET DVBRTN="-1^MISSING DFN"
QUIT
+4 NEW DVBVBA,DVBTIT,DVBLIST,DVNCT,DVBTT
+5 SET DVBRTN=0
+6 SET DVBVBA=$$GET1^DIQ(200,DFN,29)
+7 SET DVBVBA=$$UP^XLFSTR(DVBVBA)
+8 IF $GET(DVBVBA)["VBA"
SET DVBRTN=1
QUIT
+9 SET DVBTIT=$$GET1^DIQ(200,DFN,8)
Begin DoDot:1
+10 IF $GET(DVBTIT)=""
QUIT
+11 SET DVBTIT=$$UP^XLFSTR(DVBTIT)
+12 SET DVBLIST=$$GET^XPAR("PKG","DVBAB CAPRI VHA TITLE",1,"Q")
+13 IF $DATA(DVBLIST)
Begin DoDot:2
+14 SET DVNCT=0
+15 FOR
SET DVNCT=DVNCT+1
SET DVBTT=$PIECE(DVBLIST,"*",DVNCT)
if DVBTT=""
QUIT
Begin DoDot:3
+16 IF DVBTT[DVBTIT
SET DVBRTN=1
QUIT
End DoDot:3
+17 QUIT
End DoDot:2
End DoDot:1
+18 QUIT
LOCATION(DVBRTN) ;
+1 KILL DVBRTN
SET DVBRTN=""
+2 SET DVBRTN=$$GET^XPAR("PKG","DVBAB CAPRI EFOLDER LOCATION",1,"Q")
+3 QUIT
PROVIDER(DVBRTN,DFN) ;
+1 KILL DVBRTN
SET DVBRTN=0
+2 NEW DVBPROV,DVBPROV2
+3 SET DVBPROV=""
DO OWNSKEY^XUSRB(.DVBPROV,"PROVIDER",DFN)
IF $GET(DVBPROV(0))=1
SET DVBRTN=1
QUIT
+4 SET DVBPROV2=""
DO OWNSKEY^XUSRB(.DVBPROV2,"XUORES",DFN)
IF $GET(DVBPROV2(0))=1
SET DVBRTN=1
QUIT
+5 QUIT
