Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DVBCENQ

DVBCENQ.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Per VHA Directive 6402 this routine should not be modified
  1. ; Reference to GET^XPAR in ICR #2263
  1. ; Reference to OWNSKEY^XUSER in ICR #3277
  1. ; Reference to UP^XLFSTR in ICR #10104
  1. ;
  1. G EN
  1. PRINT D VARS^DVBCUTIL,^DVBCENQ1
  1. I $D(ZTQUEUED) G EXIT ;entry point for TaskMan
  1. S (NAME,SSN,CNUM,ADR1,ADR2,ADR3,CITY,STATE,ZIP,HOMPHON,BUSPHON,OTHDIS)=""
  1. Q
  1. ;
  1. EN K ^TMP($J) S Y=DT X ^DD("DD") S FDT(0)=Y D HOME^%ZIS S FF=IOF
  1. W @FF,"2507 Request Inquiry",!!!
  1. 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
  1. I +Y<0 W " ???",*7 G EN
  1. S JI=$P(Y,U,2),(DA,DA(1),REQDA)=+Y
  1. ;
  1. DEVICE W ! S %ZIS="AEQ",%ZIS("B")="HOME",%ZIS("A")="Output device: " D ^%ZIS G:POP EXIT
  1. 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)=""
  1. I D ^%ZTLOAD G:'$D(ZTSK) EXIT W !!,"Request queued",!! G EXIT
  1. U IO D PRINT D ^%ZISC G EN
  1. ;
  1. EXIT K ^TMP($J),TSTA1,TSTAT,XCNP
  1. D:$D(ZTQUEUED) KILL^%ZTLOAD G KILL^DVBCUTIL
  1. ;
  1. EDIPIQ(Y,DFN) ;
  1. K Y,DVEDIPI S Y=""
  1. I '$D(DFN) S Y=0 Q
  1. S DVBED="" F S DVBED=$O(^DGCN(391.91,"B",DFN,DVBED)) D Q:DVBED=""
  1. .Q:DVBED=""
  1. .I $P($G(^DGCN(391.91,DVBED,2)),U)'["DOD" Q
  1. .S DVEDIPI=$P(^DGCN(391.91,DVBED,2),U,2)
  1. S Y=$G(DVEDIPI) I Y="" S Y=0
  1. Q
  1. EDIPIQ2(DVBRTN,DFN) ;
  1. K DVBRTN,DVEDIPI S DVBRTN=""
  1. N DVBED,DVBBOS,DVEDIPI,VASV
  1. I $G(DFN)="" S DVBRTN=0 Q
  1. S DVBED="" F S DVBED=$O(^DGCN(391.91,"B",DFN,DVBED)) D Q:DVBED=""
  1. .Q:DVBED=""
  1. .I $P($G(^DGCN(391.91,DVBED,2)),U)'["DOD" Q
  1. .S DVEDIPI=$P(^DGCN(391.91,DVBED,2),U,2)
  1. S DVBRTN=$G(DVEDIPI) I DVBRTN="" S DVBRTN=0
  1. D SVC^VADPT
  1. S DVBBOS=$P($G(VASV(6,1)),U,2) I DVBBOS="" S DVBBOS=0
  1. S DVBRTN=$G(DVBRTN)_"^"_$G(DVBBOS)
  1. D KVAR^VADPT
  1. Q
  1. SELFREF(DVBDBQ,DFN) ;
  1. K DVBDBQ S DVBDBQ=""
  1. N DVBED,DVBSF,DVBDT,X1,X2,X,CNT,DVBYR,DVBYEAR
  1. I $G(DFN)="" S DVBDBQ=0 Q
  1. S CNT=0
  1. S DVBDT="" F S DVBDT=$O(^DVB(396.17,"C",DVBDT),-1) D Q:DVBDT=""
  1. .S X1=DT,X2=DVBDT,DVBYR=365
  1. .S DVBYEAR=+$E(DT,1,3)+1700 I $$LEAPYEAR(DVBYEAR) S DVBYR=366
  1. .D ^%DTC I X>DVBYR Q
  1. .Q:DVBDT=""
  1. .S DVBED="" F S DVBED=$O(^DVB(396.17,"C",DVBDT,DVBED)) D Q:DVBED=""
  1. ..S DVBDFN=$$GET1^DIQ(396.17,DVBED,".01","I") I DVBDFN'=DFN Q
  1. ..S DVBSF=$$GET1^DIQ(396.17,DVBED,"25","I") Q:DVBSF'="Y"
  1. ..S CNT=CNT+1 S DVBDBQ(CNT)=$$FMTE^XLFDT(DVBDT,"5D")_" "_$$GET1^DIQ(396.17,DVBED,"9","I")
  1. ..Q
  1. Q
  1. LEAPYEAR(YEAR) ;
  1. N RETVAL S RETVAL=0
  1. I YEAR#400=0 S RETVAL=1
  1. I YEAR#100=0 S RETVAL=0
  1. I YEAR#4=0 S RETVAL=1
  1. Q RETVAL
  1. EFOLDER(DVBRTN,DFN) ;
  1. ;return is 0, 1 or -1
  1. K DVBRTN S DVBRTN=""
  1. I $G(DFN)="" S DVBRTN="-1^MISSING DFN" Q
  1. N DVBVBA,DVBTIT,DVBLIST,DVNCT,DVBTT
  1. S DVBRTN=0
  1. S DVBVBA=$$GET1^DIQ(200,DFN,29)
  1. S DVBVBA=$$UP^XLFSTR(DVBVBA)
  1. I $G(DVBVBA)["VBA" S DVBRTN=1 Q
  1. S DVBTIT=$$GET1^DIQ(200,DFN,8) D
  1. .I $G(DVBTIT)="" Q
  1. .S DVBTIT=$$UP^XLFSTR(DVBTIT)
  1. .S DVBLIST=$$GET^XPAR("PKG","DVBAB CAPRI VHA TITLE",1,"Q")
  1. .I $D(DVBLIST) D
  1. ..S DVNCT=0
  1. ..F S DVNCT=DVNCT+1 S DVBTT=$P(DVBLIST,"*",DVNCT) Q:DVBTT="" D
  1. ...I DVBTT[DVBTIT S DVBRTN=1 Q
  1. ..Q
  1. Q
  1. LOCATION(DVBRTN) ;
  1. K DVBRTN S DVBRTN=""
  1. S DVBRTN=$$GET^XPAR("PKG","DVBAB CAPRI EFOLDER LOCATION",1,"Q")
  1. Q
  1. PROVIDER(DVBRTN,DFN) ;
  1. K DVBRTN S DVBRTN=0
  1. N DVBPROV,DVBPROV2
  1. S DVBPROV="" D OWNSKEY^XUSRB(.DVBPROV,"PROVIDER",DFN) I $G(DVBPROV(0))=1 S DVBRTN=1 Q
  1. S DVBPROV2="" D OWNSKEY^XUSRB(.DVBPROV2,"XUORES",DFN) I $G(DVBPROV2(0))=1 S DVBRTN=1 Q
  1. Q