Routine: AGED13

AGED13 ; IHS/ASDS/EFG - EDIT PAGE 6 - VETERAN'S INFO ;

 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

VAR ;

 S AG("PG")=6

 G READ:$G(^DPT(DFN,"VET"))="Y"

 S AG("N")=1

 S DA=DFN

 S ROUTID=$P($T(+1)," ")  ;SET ROUTINE ID FOR PROGRAMMER VIEW

 D ^AGED

 ;THESE KILLS NEED TO BE DONE VIA FILEMAN CORRECTLY. COMMENT BY TPF 4/27/2005

 I $G(^DPT(DFN,"VET"))="N" K ^DPT(DFN,.3),^DPT(DFN,.31),^DPT(DFN,.321),^DPT(DFN,.32),^DPT("APOS",9,DFN),^AUPNPAT(DFN,32),^AUPNPAT(DFN,19)

 K ^UTILITY("DIQ1",$J)

 F AG=1:1:AG("N") D

 . S AGSCRN=$P($T(@1+AG),";;",2,10)

 . S DIC=$P(AGSCRN,U,3)

 . S DR=$P(AGSCRN,U,4)

 . W !,AG,".",?(40-$L($P($G(^DD(DIC,DR,0)),U))),$P($G(^DD(DIC,DR,0)),U)," : "

 . S AGVETFLD=$$GET1^DIQ(DIC,DFN,DR)

 . I $G(^AUPNPAT(DFN,35))'="" W AGVETFLD,?50,"Obtained on " S Y=$P($G(^AUPNPAT(DFN,35)),U) X ^DD("DD") W Y

 W !,$G(AGLINE("-"))

 D VERIF^AGUTILS  ;ADDED

 W !!,AGLINE("EQ")

 Q:$D(AGSEENLY)

 K DIR

 S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "

 S DIR("?")="Enter your choice now."

 S DIR("?",1)="You may enter the item number of the field you wish to edit,"

 S DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"

 S DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"

 S DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."

 D READ^AGED1

 G END:$D(DTOUT)!$D(DFOUT)!$D(DLOUT)!$D(DUOUT)!$D(DIROUT)

 G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED")) I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G VAR

 S AGY=Y

 F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N"))  D @($P("VET,",",",AG("SEL")))

 D UPDATE1^AGED(DUZ(2),DFN,13,"")

 G VAR

NONE ;

READ D DRAW

 Q:$D(AGSEENLY)

 W !!,AGLINE("EQ")

 K DIR

 S DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "

 D READ^AGED1

 G END:$D(DTOUT)!$D(DFOUT)!$D(DLOUT)!$D(DUOUT)!$D(DIROUT)

 G:$D(AG("ED"))&'$D(AGXTERN) @("^AGED"_AG("ED")) I $D(DQOUT)!(+Y<1)!(+Y>AG("N")) W !!,"You must enter a number from 1 to ",AG("N") H 2 G READ

 I +Y>1,'$D(^DPT(DFN,"VET")) W *7,"  Must be VETERAN.  Edit #1 first." H 2 G READ

 S AGY=Y

 F AGI=1:1 S AG("SEL")=+$P(AGY,",",AGI) Q:AG("SEL")<1!(AG("SEL")>AG("N"))  D @($P("VET,SVCBR,SVCENT,SVCSEP,VIETSVC,SVCCON,CLMNUM,DISAB,VACARD,",",",AG("SEL")))

 D UPDATE1^AGED(DUZ(2),DFN,13,"")

 G VAR

END K ^UTILITY("DIQ1",$J),AG,AGI,AGY,DTOUT,DLOUT,DQOUT,DA,DIC,DIE,DR,AGSCRN,AGVETFLD

 K ROUTID

 Q:$D(DFOUT)

 Q:$D(AGXTERN)

 Q:$D(AGSEENLY)

 I $D(DUOUT) K DIR G ^AGEDBEA

 K DIR

 G ^AGED8

DRAW ;EP

 S AG("N")=9

 S DA=DFN

 S AG("PG")=6

 S ROUTID=$P($T(+1)," ")  ;SET ROUTINE ID FOR PROGRAMMER VIEW

 D ^AGED

 I $G(^DPT(DFN,"VET"))="N" K ^DPT(DFN,.3),^DPT(DFN,.31),^DPT(DFN,.321),^DPT(DFN,.32),^DPT("APOS",9,DFN),^AUPNPAT(DFN,32),^AUPNPAT(DFN,19)

 K ^UTILITY("DIQ1",$J)

 F AG=1:1:AG("N") D

 . S AGSCRN=$P($T(@1+AG),";;",2,10)

 . S DIC=$P(AGSCRN,U,3)

 . S DR=$P(AGSCRN,U,4)

 . W !,AG,".",?(40-$L($P($G(^DD(DIC,DR,0)),U))),$P($G(^DD(DIC,DR,0)),U)," : "

 . S AGVETFLD=$$GET1^DIQ(DIC,DFN,DR)

 . I $D(AGVETFLD)&(AG=1) W AGVETFLD,?50,"Obtained on " S Y=$P($G(^AUPNPAT(DFN,35)),U) X ^DD("DD") W Y

 . I $D(AGVETFLD)&(AG=8) D

 .. I $L(AGVETFLD)>37 W $E(AGVETFLD,1,37),! W ?43,$E(AGVETFLD,38,60)

 .. I $L(AGVETFLD)<38 W AGVETFLD

 . I $D(AGVETFLD)&(AG'=8)&(AG'=1) D

 .. W AGVETFLD

 . I AG=9,$P($G(^AUPNPAT(DFN,32)),U)="Y" D

 .. S Y=$P($G(^AUPNPAT(DFN,32)),U,2) D DD^%DT

 .. W ?49,"DATE OBTAINED: ",Y

 . I AG=9,$P($G(^AUPNPAT(DFN,32)),U)="N" D

 .. W ?48,"TOLD HOW TO OBTAIN VA CARD? "

 .. I $P($G(^AUPNPAT(DFN,32)),U,3)["N" W "NO"

 .. I $P($G(^AUPNPAT(DFN,32)),U,3)["Y" W "YES"

 W !,$G(AGLINE("-"))

 D VERIF^AGUTILS

VET ;VETERAN FIELD

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=1901

 S DIE("NO^")=""

 D ^DIE

 S:$D(Y) DUOUT=""

 ;ADD NEW FIELD FOR VET DATA TO TRACK WHEN VETERAN FIELD IS EDITED

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR="3501////^S X=DT"

 D ^DIE

SVCBR ;LAST SERVICE BRANCH FIELD

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=.325

 D ^DIE

 S:$D(Y) DUOUT=""

SVCENT ;LAST SERVICE ENTRY DATE

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=.326

 D ^DIE

 S:$D(Y) DUOUT=""

SVCSEP ;LAST SERVICE SEPARATION DATE

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=.327

 D ^DIE

 S:$D(Y) DUOUT=""

VIETSVC ;VIETNAM SERVICE INDICATED

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=.32101

 D ^DIE

 S:$D(Y) DUOUT=""

SVCCON ;SERVICE CONNECTED

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=.301

 D ^DIE

 S:$D(Y) DUOUT=""

CLMNUM ;CLAIM NUMBER

 K DUOUT

 S DIE="^DPT("

 S DA=DFN

 S DR=.313

 D ^DIE

 S:$D(Y) DUOUT=""

DISAB ;RATED DISABILITIES

 K DUOUT

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR=1901

 D ^DIE

 S:$D(Y) DUOUT=""

VACARD ;DOES PATIENT HAVE A VALID VA CARD

 N DUOUT

 S DIE="^AUPNPAT("

 S DA=DFN

 S DR=3201

 D ^DIE

 S:$D(Y) DUOUT=""

 ;IF VALID VA CARD, PROMPT FOR DATE CARD COPY WAS OBTAINED

 I $P($G(^AUPNPAT(DFN,32)),U)="Y" D

 . I $P($G(^AUPNPAT(DFN,32)),U,3)'="" D

 .. S $P(^AUPNPAT(DFN,32),U,3)=""

 . N DUOUT

 . S DIE="^AUPNPAT("

 . S DA=DFN

 . S DR=3202

 . D ^DIE

 . S:$D(Y) DUOUT=""

 ;IF NO VALID VA CARD AND DATE OBTAINED EXISTS, DELETE DATE OBTAINED

 I $P($G(^AUPNPAT(DFN,32)),U)'="Y",$P($G(^AUPNPAT(DFN,32)),U,2)'="" D

 . S $P(^AUPNPAT(DFN,32),U,2)=""

 ;IF VALID CARD=NULL CLEAR FIELDS 3202 AND 3203

 I $P($G(^AUPNPAT(DFN,32)),U)="" D

 . S $P(^AUPNPAT(DFN,32),U,2)=""

 . S $P(^AUPNPAT(DFN,32),U,3)=""

 ;IF VALID VA CARD = NO, PROMPT FOR INFORMED HOW TO OBTAIN

 I $P($G(^AUPNPAT(DFN,32)),U)="N" D

 . I $P(^AUPNPAT(DFN,32),U,2)'="" D

 .. S DIR(0)="Y"

 .. S DIR("A")="There is a card copy date obtained field on this record. Are you sure this what you want to do ? "

 .. D ^DIR K DIR

 .. G:Y=0 VACARD

 . N DUOUT

 . S DIE="^AUPNPAT("

 . S DA=DFN

 . S DR=3203

 . D ^DIE

 . S:$D(Y) DUOUT=""

 . K DIC,DIE

 ;NOT IN USE AT THIS TIME

 ;CHECK TO SEE IF PATIENT TOO YOUNG FOR SERVICE. THIS IS TAKEN FROM

 ;VA CODE IN RTN ^DGINP AND MODIFIED SLIGHTLY

 ;X= PAT DOB,

TOOYUNG(AGDA,X) ;

N L

 S L=^DPT(AGDA,0),Y=+$P(L,"^",3)

 I X-Y\10000<15 X ^DD("DD") W !!,"This service entry date would make the patient too young for service.",!,"DOB ",Y,!,*7 K X Q 1

EDIT S DIE=2,DA=DFN,DR=$P($P(AGSCRN,";;",AG("SEL")),U,4)

 I AG("SEL")'=1,$D(^DPT(DFN,"VET")),^DPT(DFN,"VET")="N" K ^("VET"),^DPT(DFN,.3),^DPT(DFN,.31),^DPT(DFN,.321),^DPT(DFN,.32),^DPT("APOS",9,DFN) Q

 I AG("SEL")'=1,'$D(^DPT(DFN,"VET")) Q

 D ^DIE

ADD ;EP - ADD A PATIENT

 D VET

 I $D(^DPT(DFN,"VET")),^("VET")="Y"  D

 . D SVCBR Q:$D(Y)

 . D SVCENT Q:$D(Y)

 . D SVCSEP Q:$D(Y)

 . D VIETSVC Q:$D(Y)

 . D SVCCON Q:$D(Y)

 . D CLMNUM Q:$D(Y)

 . D DISAB Q:$D(Y)

 . D VACARD Q:$D(Y)

 K AGSCRN I $D(^DPT(DFN,"VET")),^("VET")="N" K ^DPT("APOS",9,DFN)

 D UPDATE1^AGED(DUZ(2),DFN,13,"")

 G L11^AG0

 ; ****************************************************************

 ; ON LINES BELOW:

 ; PIECE 1= FLD LBL

 ; PIECE 2= POSITION ON LINE TO DISP FLD

 ; PIECE 3= FILE #

 ; PIECE 4= FLD #

1 ;

 ;;VETERAN (Y/N)?^26^2^1901

 ;;SERVICE BRANCH [LAST]^19^2^.325

 ;;SERVICE ENTRY DATE [LAST]^15^2^.326

 ;;SERVICE SEPARATION DATE [LAST]^10^2^.327

 ;;VIETNAM SERVICE INDICATED?^14^2^.32101

 ;;SERVICE CONNECTED?^22^2^.301

 ;;CLAIM NUMBER^28^2^.313

 ;;DESC OF VA DISABILITY^19^9000001^1901

 ;;DOES THE PATIENT HAVE A VALID VA CARD?^1^9000001^3201

AGED13    ; IHS/ASDS/EFG - EDIT PAGE 6 - VETERAN'S INFO ;

 +1       ;;7.1;PATIENT REGISTRATION;;AUG 25,2005

 +2       ;

VAR       ;

 +1        SET AG("PG")=6

 +2        IF $GET(^DPT(DFN,"VET"))="Y"

               GOTO READ

 +3        SET AG("N")=1

 +4        SET DA=DFN

 +5       ;SET ROUTINE ID FOR PROGRAMMER VIEW

           SET ROUTID=$PIECE($TEXT(+1)," ")

 +6        DO ^AGED

 +7       ;THESE KILLS NEED TO BE DONE VIA FILEMAN CORRECTLY. COMMENT BY TPF 4/27/2005

 +8        IF $GET(^DPT(DFN,"VET"))="N"

               KILL ^DPT(DFN,.3),^DPT(DFN,.31),^DPT(DFN,.321),^DPT(DFN,.32),^DPT("APOS",9,DFN),^AUPNPAT(DFN,32),^AUPNPAT(DFN,19)

 +9        KILL ^UTILITY("DIQ1",$JOB)

 +10       FOR AG=1:1:AG("N")

               Begin DoDot:1

 +11               SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,10)

 +12               SET DIC=$PIECE(AGSCRN,U,3)

 +13               SET DR=$PIECE(AGSCRN,U,4)

 +14               WRITE !,AG,".",?(40-$LENGTH($PIECE($GET(^DD(DIC,DR,0)),U))),$PIECE($GET(^DD(DIC,DR,0)),U)," : "

 +15               SET AGVETFLD=$$GET1^DIQ(DIC,DFN,DR)

 +16               IF $GET(^AUPNPAT(DFN,35))'=""

                       WRITE AGVETFLD,?50,"Obtained on "

                       SET Y=$PIECE($GET(^AUPNPAT(DFN,35)),U)

                       XECUTE ^DD("DD")

                       WRITE Y

               End DoDot:1

 +17       WRITE !,$GET(AGLINE("-"))

 +18      ;ADDED

           DO VERIF^AGUTILS

 +19       WRITE !!,AGLINE("EQ")

 +20       IF $DATA(AGSEENLY)

               QUIT

 +21       KILL DIR

 +22       SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "

 +23       SET DIR("?")="Enter your choice now."

 +24       SET DIR("?",1)="You may enter the item number of the field you wish to edit,"

 +25       SET DIR("?",2)="OR you can enter 'P#' where P stands for 'page' and '#' stands for"

 +26       SET DIR("?",3)="the page you wish to jump to, OR enter '^' to go back one page"

 +27       SET DIR("?",4)="OR, enter '^^' to exit the edit screens, OR RETURN to go to the next screen."

 +28       DO READ^AGED1

 +29       IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DLOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               GOTO END

 +30       IF $DATA(AG("ED"))&'$DATA(AGXTERN)

               GOTO @("^AGED"_AG("ED"))

           IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))

               WRITE !!,"You must enter a number from 1 to ",AG("N")

               HANG 2

               GOTO VAR

 +31       SET AGY=Y

 +32       FOR AGI=1:1

               SET AG("SEL")=+$PIECE(AGY,",",AGI)

               IF AG("SEL")<1!(AG("SEL")>AG("N"))

                   QUIT

               DO @($PIECE("VET,",",",AG("SEL")))

 +33       DO UPDATE1^AGED(DUZ(2),DFN,13,"")

 +34       GOTO VAR

NONE      ;

READ       DO DRAW

 +1        IF $DATA(AGSEENLY)

               QUIT

 +2        WRITE !!,AGLINE("EQ")

 +3        KILL DIR

 +4        SET DIR("A")="CHANGE which item? (1-"_AG("N")_") NONE// "

 +5        DO READ^AGED1

 +6        IF $DATA(DTOUT)!$DATA(DFOUT)!$DATA(DLOUT)!$DATA(DUOUT)!$DATA(DIROUT)

               GOTO END

 +7        IF $DATA(AG("ED"))&'$DATA(AGXTERN)

               GOTO @("^AGED"_AG("ED"))

           IF $DATA(DQOUT)!(+Y<1)!(+Y>AG("N"))

               WRITE !!,"You must enter a number from 1 to ",AG("N")

               HANG 2

               GOTO READ

 +8        IF +Y>1

               IF '$DATA(^DPT(DFN,"VET"))

                   WRITE *7,"  Must be VETERAN.  Edit #1 first."

                   HANG 2

                   GOTO READ

 +9        SET AGY=Y

 +10       FOR AGI=1:1

               SET AG("SEL")=+$PIECE(AGY,",",AGI)

               IF AG("SEL")<1!(AG("SEL")>AG("N"))

                   QUIT

               DO @($PIECE("VET,SVCBR,SVCENT,SVCSEP,VIETSVC,SVCCON,CLMNUM,DISAB,VACARD,",",",AG("SEL")))

 +11       DO UPDATE1^AGED(DUZ(2),DFN,13,"")

 +12       GOTO VAR

 +13       QUIT

END        KILL ^UTILITY("DIQ1",$JOB),AG,AGI,AGY,DTOUT,DLOUT,DQOUT,DA,DIC,DIE,DR,AGSCRN,AGVETFLD

 +1        KILL ROUTID

 +2        IF $DATA(DFOUT)

               QUIT

 +3        IF $DATA(AGXTERN)

               QUIT

 +4        IF $DATA(AGSEENLY)

               QUIT

 +5        IF $DATA(DUOUT)

               KILL DIR

               GOTO ^AGEDBEA

 +6        KILL DIR

 +7        GOTO ^AGED8

DRAW      ;EP

 +1        SET AG("N")=9

 +2        SET DA=DFN

 +3        SET AG("PG")=6

 +4       ;SET ROUTINE ID FOR PROGRAMMER VIEW

           SET ROUTID=$PIECE($TEXT(+1)," ")

 +5        DO ^AGED

 +6        IF $GET(^DPT(DFN,"VET"))="N"

               KILL ^DPT(DFN,.3),^DPT(DFN,.31),^DPT(DFN,.321),^DPT(DFN,.32),^DPT("APOS",9,DFN),^AUPNPAT(DFN,32),^AUPNPAT(DFN,19)

 +7        KILL ^UTILITY("DIQ1",$JOB)

 +8        FOR AG=1:1:AG("N")

               Begin DoDot:1

 +9                SET AGSCRN=$PIECE($TEXT(@1+AG),";;",2,10)

 +10               SET DIC=$PIECE(AGSCRN,U,3)

 +11               SET DR=$PIECE(AGSCRN,U,4)

 +12               WRITE !,AG,".",?(40-$LENGTH($PIECE($GET(^DD(DIC,DR,0)),U))),$PIECE($GET(^DD(DIC,DR,0)),U)," : "

 +13               SET AGVETFLD=$$GET1^DIQ(DIC,DFN,DR)

 +14               IF $DATA(AGVETFLD)&(AG=1)

                       WRITE AGVETFLD,?50,"Obtained on "

                       SET Y=$PIECE($GET(^AUPNPAT(DFN,35)),U)

                       XECUTE ^DD("DD")

                       WRITE Y

 +15               IF $DATA(AGVETFLD)&(AG=8)

                       Begin DoDot:2

 +16                       IF $LENGTH(AGVETFLD)>37

                               WRITE $EXTRACT(AGVETFLD,1,37),!

                               WRITE ?43,$EXTRACT(AGVETFLD,38,60)

 +17                       IF $LENGTH(AGVETFLD)<38

                               WRITE AGVETFLD

                       End DoDot:2

 +18               IF $DATA(AGVETFLD)&(AG'=8)&(AG'=1)

                       Begin DoDot:2

 +19                       WRITE AGVETFLD

                       End DoDot:2

 +20               IF AG=9

                       IF $PIECE($GET(^AUPNPAT(DFN,32)),U)="Y"

                           Begin DoDot:2

 +21                           SET Y=$PIECE($GET(^AUPNPAT(DFN,32)),U,2)

                               DO DD^%DT

 +22                           WRITE ?49,"DATE OBTAINED: ",Y

                           End DoDot:2

 +23               IF AG=9

                       IF $PIECE($GET(^AUPNPAT(DFN,32)),U)="N"

                           Begin DoDot:2

 +24                           WRITE ?48,"TOLD HOW TO OBTAIN VA CARD? "

 +25                           IF $PIECE($GET(^AUPNPAT(DFN,32)),U,3)["N"

                                   WRITE "NO"

 +26                           IF $PIECE($GET(^AUPNPAT(DFN,32)),U,3)["Y"

                                   WRITE "YES"

                           End DoDot:2

               End DoDot:1

 +27       WRITE !,$GET(AGLINE("-"))

 +28       DO VERIF^AGUTILS

 +29       QUIT

VET       ;VETERAN FIELD

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=1901

 +5        SET DIE("NO^")=""

 +6        DO ^DIE

 +7        IF $DATA(Y)

               SET DUOUT=""

 +8       ;ADD NEW FIELD FOR VET DATA TO TRACK WHEN VETERAN FIELD IS EDITED

 +9        SET DIE="^AUPNPAT("

 +10       SET DA=DFN

 +11       SET DR="3501////^S X=DT"

 +12       DO ^DIE

 +13       QUIT

SVCBR     ;LAST SERVICE BRANCH FIELD

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=.325

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

SVCENT    ;LAST SERVICE ENTRY DATE

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=.326

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

SVCSEP    ;LAST SERVICE SEPARATION DATE

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=.327

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

VIETSVC   ;VIETNAM SERVICE INDICATED

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=.32101

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

SVCCON    ;SERVICE CONNECTED

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=.301

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

CLMNUM    ;CLAIM NUMBER

 +1        KILL DUOUT

 +2        SET DIE="^DPT("

 +3        SET DA=DFN

 +4        SET DR=.313

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

DISAB     ;RATED DISABILITIES

 +1        KILL DUOUT

 +2        SET DIE="^AUPNPAT("

 +3        SET DA=DFN

 +4        SET DR=1901

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7        QUIT

VACARD    ;DOES PATIENT HAVE A VALID VA CARD

 +1        NEW DUOUT

 +2        SET DIE="^AUPNPAT("

 +3        SET DA=DFN

 +4        SET DR=3201

 +5        DO ^DIE

 +6        IF $DATA(Y)

               SET DUOUT=""

 +7       ;IF VALID VA CARD, PROMPT FOR DATE CARD COPY WAS OBTAINED

 +8        IF $PIECE($GET(^AUPNPAT(DFN,32)),U)="Y"

               Begin DoDot:1

 +9                IF $PIECE($GET(^AUPNPAT(DFN,32)),U,3)'=""

                       Begin DoDot:2

 +10                       SET $PIECE(^AUPNPAT(DFN,32),U,3)=""

                       End DoDot:2

 +11               NEW DUOUT

 +12               SET DIE="^AUPNPAT("

 +13               SET DA=DFN

 +14               SET DR=3202

 +15               DO ^DIE

 +16               IF $DATA(Y)

                       SET DUOUT=""

               End DoDot:1

 +17      ;IF NO VALID VA CARD AND DATE OBTAINED EXISTS, DELETE DATE OBTAINED

 +18       IF $PIECE($GET(^AUPNPAT(DFN,32)),U)'="Y"

               IF $PIECE($GET(^AUPNPAT(DFN,32)),U,2)'=""

                   Begin DoDot:1

 +19                   SET $PIECE(^AUPNPAT(DFN,32),U,2)=""

                   End DoDot:1

 +20      ;IF VALID CARD=NULL CLEAR FIELDS 3202 AND 3203

 +21       IF $PIECE($GET(^AUPNPAT(DFN,32)),U)=""

               Begin DoDot:1

 +22               SET $PIECE(^AUPNPAT(DFN,32),U,2)=""

 +23               SET $PIECE(^AUPNPAT(DFN,32),U,3)=""

               End DoDot:1

 +24      ;IF VALID VA CARD = NO, PROMPT FOR INFORMED HOW TO OBTAIN

 +25       IF $PIECE($GET(^AUPNPAT(DFN,32)),U)="N"

               Begin DoDot:1

 +26               IF $PIECE(^AUPNPAT(DFN,32),U,2)'=""

                       Begin DoDot:2

 +27                       SET DIR(0)="Y"

 +28                       SET DIR("A")="There is a card copy date obtained field on this record. Are you sure this what you want to do ? "

 +29                       DO ^DIR

                           KILL DIR

 +30                       IF Y=0

                               GOTO VACARD

                       End DoDot:2

 +31               NEW DUOUT

 +32               SET DIE="^AUPNPAT("

 +33               SET DA=DFN

 +34               SET DR=3203

 +35               DO ^DIE

 +36               IF $DATA(Y)

                       SET DUOUT=""

 +37               KILL DIC,DIE

               End DoDot:1

 +38       QUIT

 +39      ;NOT IN USE AT THIS TIME

 +40      ;CHECK TO SEE IF PATIENT TOO YOUNG FOR SERVICE. THIS IS TAKEN FROM

 +41      ;VA CODE IN RTN ^DGINP AND MODIFIED SLIGHTLY

 +42      ;X= PAT DOB,

TOOYUNG(AGDA,X) ;

 +1        NEW L

 +2        SET L=^DPT(AGDA,0)

           SET Y=+$PIECE(L,"^",3)

 +3        IF X-Y\10000<15

               XECUTE ^DD("DD")

               WRITE !!,"This service entry date would make the patient too young for service.",!,"DOB ",Y,!,*7

               KILL X

               QUIT 1

 +4        QUIT

EDIT       SET DIE=2

           SET DA=DFN

           SET DR=$PIECE($PIECE(AGSCRN,";;",AG("SEL")),U,4)

 +1        IF AG("SEL")'=1

               IF $DATA(^DPT(DFN,"VET"))

                   IF ^DPT(DFN,"VET")="N"

                       KILL ^("VET"),^DPT(DFN,.3),^DPT(DFN,.31),^DPT(DFN,.321),^DPT(DFN,.32),^DPT("APOS",9,DFN)

                       QUIT

 +2        IF AG("SEL")'=1

               IF '$DATA(^DPT(DFN,"VET"))

                   QUIT

 +3        DO ^DIE

 +4        QUIT

ADD       ;EP - ADD A PATIENT

 +1        DO VET

 +2        IF $DATA(^DPT(DFN,"VET"))

               IF ^("VET")="Y"

                   Begin DoDot:1

 +3                    DO SVCBR

                       IF $DATA(Y)

                           QUIT

 +4                    DO SVCENT

                       IF $DATA(Y)

                           QUIT

 +5                    DO SVCSEP

                       IF $DATA(Y)

                           QUIT

 +6                    DO VIETSVC

                       IF $DATA(Y)

                           QUIT

 +7                    DO SVCCON

                       IF $DATA(Y)

                           QUIT

 +8                    DO CLMNUM

                       IF $DATA(Y)

                           QUIT

 +9                    DO DISAB

                       IF $DATA(Y)

                           QUIT

 +10                   DO VACARD

                       IF $DATA(Y)

                           QUIT

                   End DoDot:1

 +11       KILL AGSCRN

           IF $DATA(^DPT(DFN,"VET"))

               IF ^("VET")="N"

                   KILL ^DPT("APOS",9,DFN)

 +12       DO UPDATE1^AGED(DUZ(2),DFN,13,"")

 +13       GOTO L11^AG0

 +14      ; ****************************************************************

 +15      ; ON LINES BELOW:

 +16      ; PIECE 1= FLD LBL

 +17      ; PIECE 2= POSITION ON LINE TO DISP FLD

 +18      ; PIECE 3= FILE #

 +19      ; PIECE 4= FLD #

1         ;

 +1       ;;VETERAN (Y/N)?^26^2^1901

 +2       ;;SERVICE BRANCH [LAST]^19^2^.325

 +3       ;;SERVICE ENTRY DATE [LAST]^15^2^.326

 +4       ;;SERVICE SEPARATION DATE [LAST]^10^2^.327

 +5       ;;VIETNAM SERVICE INDICATED?^14^2^.32101

 +6       ;;SERVICE CONNECTED?^22^2^.301

 +7       ;;CLAIM NUMBER^28^2^.313

 +8       ;;DESC OF VA DISABILITY^19^9000001^1901

 +9       ;;DOES THE PATIENT HAVE A VALID VA CARD?^1^9000001^3201

AGED13.m