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
Q
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
Q
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
Q
SVCBR ;LAST SERVICE BRANCH FIELD
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.325
D ^DIE
S:$D(Y) DUOUT=""
Q
SVCENT ;LAST SERVICE ENTRY DATE
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.326
D ^DIE
S:$D(Y) DUOUT=""
Q
SVCSEP ;LAST SERVICE SEPARATION DATE
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.327
D ^DIE
S:$D(Y) DUOUT=""
Q
VIETSVC ;VIETNAM SERVICE INDICATED
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.32101
D ^DIE
S:$D(Y) DUOUT=""
Q
SVCCON ;SERVICE CONNECTED
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.301
D ^DIE
S:$D(Y) DUOUT=""
Q
CLMNUM ;CLAIM NUMBER
K DUOUT
S DIE="^DPT("
S DA=DFN
S DR=.313
D ^DIE
S:$D(Y) DUOUT=""
Q
DISAB ;RATED DISABILITIES
K DUOUT
S DIE="^AUPNPAT("
S DA=DFN
S DR=1901
D ^DIE
S:$D(Y) DUOUT=""
Q
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
Q
;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
Q
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
Q
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
