WVGETAL1.m

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 ---WVGETAL1   972     printed  Apr 09, 2024@21:50:23                                                                                                                                                                                                     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      ;