WVGETAL1 ;HCIOFO/FT-Autoload Female Patients (cont.) ;2/18/00 13:17
;;1.0;WOMEN'S HEALTH;**7,10**;Sep 30, 1998
EC ; prompt for Eligibility codes
W ! K DIR
S DIR(0)="Y",DIR("A")=" Include patients by eligibility code, too"
S DIR("?")="Answer YES to include non-veteran patients with a desired eligibility code"
D ^DIR K DIR
I $D(DIRUT) S WVPOP=1
Q:$G(WVPOP)!(Y=0)
K DIC N WVLOOP
S WVLOOP=0,DIC="^DIC(8,",Y=0
F Q:Y<0 D
.S WVLOOP=WVLOOP+1
.S DIC(0)="AEMQZ"
.S DIC("A")=" Select "_$S(WVLOOP>1:"Next ",1:"")_"Eligibility Code: "
.D ^DIC
.S:$D(DTOUT)!($D(DUOUT)) WVPOP=1
.I $D(DTOUT)!($D(DUOUT))!(Y<0) Q
.S WVEC(+Y)=""
.Q
K DIC
Q
VECCHK(WVN) ; Veteran/Eligibility Code check
N DFN,WVLOOP,VAEL,VAERR,X,Y
; get veteran status
I $$GET1^DIQ(2,WVN,1901,"I")="Y" Q 1
S DFN=WVN
D ELIG^VADPT ;get elibility code
S WVLOOP=+$P($G(VAEL(1)),U,1) ;VAEL(1)=internal^external
I 'WVLOOP Q 0
I $D(WVEC(WVLOOP)) Q 1
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HWVGETAL1 972 printed Dec 13, 2024@02:46:58 Page 2
WVGETAL1 ;HCIOFO/FT-Autoload Female Patients (cont.) ;2/18/00 13:17
+1 ;;1.0;WOMEN'S HEALTH;**7,10**;Sep 30, 1998
EC ; prompt for Eligibility codes
+1 WRITE !
KILL DIR
+2 SET DIR(0)="Y"
SET DIR("A")=" Include patients by eligibility code, too"
+3 SET DIR("?")="Answer YES to include non-veteran patients with a desired eligibility code"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DIRUT)
SET WVPOP=1
+6 if $GET(WVPOP)!(Y=0)
QUIT
+7 KILL DIC
NEW WVLOOP
+8 SET WVLOOP=0
SET DIC="^DIC(8,"
SET Y=0
+9 FOR
if Y<0
QUIT
Begin DoDot:1
+10 SET WVLOOP=WVLOOP+1
+11 SET DIC(0)="AEMQZ"
+12 SET DIC("A")=" Select "_$SELECT(WVLOOP>1:"Next ",1:"")_"Eligibility Code: "
+13 DO ^DIC
+14 if $DATA(DTOUT)!($DATA(DUOUT))
SET WVPOP=1
+15 IF $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
QUIT
+16 SET WVEC(+Y)=""
+17 QUIT
End DoDot:1
+18 KILL DIC
+19 QUIT
VECCHK(WVN) ; Veteran/Eligibility Code check
+1 NEW DFN,WVLOOP,VAEL,VAERR,X,Y
+2 ; get veteran status
+3 IF $$GET1^DIQ(2,WVN,1901,"I")="Y"
QUIT 1
+4 SET DFN=WVN
+5 ;get elibility code
DO ELIG^VADPT
+6 ;VAEL(1)=internal^external
SET WVLOOP=+$PIECE($GET(VAEL(1)),U,1)
+7 IF 'WVLOOP
QUIT 0
+8 IF $DATA(WVEC(WVLOOP))
QUIT 1
+9 QUIT 0
+10 ;
