- 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 Feb 18, 2025@23:10:26 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