AGBIC2B ; IHS/ASDS/EFG - ENTER CURRENT COMMUNITY ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
L1 ;
K AG("HSDA"),AG("PRVCM"),AG("COMM")
W !!,"Enter PRESENT COMMUNITY: "
D DEF
D READ^AG
G:$D(DUOUT)!$D(DTOUT)!$D(DFOUT) END
I $D(DLOUT)&($D(AG("EDIT")))&($D(AG("PRVCM"))) D G L2
. S Y=AG("PRVCM")
I $D(DLOUT)!$D(DQOUT) S Y="?"
L2 ;
S DIC="^AUTTCOM("
S DIC(0)="QEM"
S X=Y
D ^DIC
G L1:Y<0
S AG("CPTR")=+Y
S AG("CITY")=$P(Y,U,2)
S:$P(^AUTTCTY($P(^AUTTCOM($P(Y,U),0),U,2),0),U,5)="Y" AG("HSDA")="Y"
L3 ;
K AG("EDIT"),AG("BIRTH"),AG("PRVDT")
W !!,"When did the patient move to this community? "
W "( ""B"" = ""at BIRTH"" ) ",!," DATE: "
D DEF1
D READ^AG
Q:$D(DTOUT)!$D(DFOUT)
G L1:$D(DUOUT)
I $D(DLOUT)&($D(AG("EDIT")))&($D(AG("PRVDT"))) D G L3A
. S Y=AG("PRVDT")
I $D(DLOUT)!$D(DQOUT) S Y="?"
L3A ;
I Y="B" D
. S AG("BIRTH")=""
. S DIC=2
. S DA=DFN
. S DR=.03
. D ^DIC
. S:$D(AG("LKDATA")) Y=AG("LKDATA")
. I $D(AG("LKERR"))!($D(AG("LKDATA"))&(+Y<99999)) D
.. W !,*7,"There is no DATE-OF-BIRTH on file.",!
.. S Y="?"
.. K AG("BIRTH")
S X=Y
S %DT=""
S %DT(0)="-NOW"
D ^%DT
K %DT(0)
G L1:X="^"
G END:$D(AG("EDIT"))&(X="")
G L3:Y<0
S AG("CDATE")=Y
L4 ;
K ^AUPNPAT(DFN,51)
S ^AUPNPAT(DFN,51,0)="^9000001.51D^"_AG("CDATE")_"^1"
S ^AUPNPAT(DFN,51,AG("CDATE"),0)=AG("CDATE")_U_DT_U_AG("CPTR")
S DIE="^AUPNPAT("
S DA=DFN
S DR="1118///"_AG("CITY")
D ^DIE
CKHSDA ;
S AG("COMM")="N"
G STCOMVER:'$D(AG("HSDA"))
D COMMVER
G:$D(DUOUT) L3
I (Y'["Y")&(Y'["N") D G CKHSDA
. D YN^AG
S AG("COMM")=Y
STCOMVER ;
D S1
S DR="1121///"_AG("COMM")
D ^DIE
G END:AG("COMM")="Y"
CKPREV ;
G END:$D(AG("BIRTH"))
G END:AG("CDATE")>"2880915"
W !!,"This patient's CURRENT COMMUNITY is "
W $S('$D(AG("HSDA")):"not within a HSDA!",1:"within a HSDA but is not verified!")
MSG1 ;
W !,"Enter any other COMMUNITY lived in since 09/16/88: "
S AG("COMM")="N"
S AG("2BPREV")=""
D READ^AG
G:$D(DUOUT)!$D(DTOUT)!$D(DFOUT) END
K AG("2BPREV")
S DIC="^AUTTCOM("
S DIC(0)="QEM"
S X=Y
D ^DIC
G END:Y<0
I $P(^AUTTCTY($P(^AUTTCOM($P(Y,U),0),U,2),0),U,5)'="Y" D G MSG1
. W !!,$P(^AUTTCOM($P(Y,U),0),U)," is not within a HSDA!"
CKPRVER ;
D COMMVER
G:$D(DUOUT)!(Y["N") CKPREV
I Y'["Y" D G CKPRVER
. D YN^AG
S AG("COMM")="Y"
SETPRV ;
D S1
S DR="1122///"_AG("COMM")
D ^DIE
G END
END ;
K AG("COMMVER"),AG("BIRTH"),AG("HSDA"),AG("PRVDT"),AG("PRVCM")
K AG("COMM"),DIC
Q
DEF ;
K AG("EDIT")
Q:'$D(^AUPNPAT(DFN,51,0))
S AG("CDATE")=$P(^AUPNPAT(DFN,51,0),U,3)
Q:AG("CDATE")=""
Q:'$D(^AUPNPAT(DFN,51,AG("CDATE")))
S AG("CPTR")=$P(^AUPNPAT(DFN,51,AG("CDATE"),0),U,3)
Q:+AG("CPTR")<1
Q:'$D(^AUTTCOM(AG("CPTR")))
W $P(^AUTTCOM(AG("CPTR"),0),U),"//"
S AG("EDIT")=""
S AG("PRVCM")=$P(^AUTTCOM(AG("CPTR"),0),U)
Q
DEF1 ;
K AG("EDIT")
I $D(^AUPNPAT(DFN,51,0)),AG("CDATE")]"" D
. S Y=$P(^AUPNPAT(DFN,51,AG("CDATE"),0),U)
. D DD^%DT
. W !,Y,"// "
. S AG("EDIT")=""
. S AG("PRVDT")=Y
Q
EDCOM ;EP - Edit Communities.
E1 ;
K DIC("S")
S DIC=9000001.51
S DR=.01
S X=DFN
D ^DIC
S DA=+Y
S DIE="^AUPNPAT("
S DR=5101
S DR(2,9000001.51)=".01;.03;S $P(^AUPNPAT(DFN,51,D1,0),U,2)=$P(^AUPNPAT(DFN,51,D1,0),U)"
D ^DIE
E2 ;
S AG("DRENT")=0
S DR=.03
S AG("CITY")=""
S DIC=9000001.51
S DA=DFN
D ^DIC
I $D(AG("LKDATA")),AG("LKDATA")]"",$D(^AUTTCOM(AG("LKDATA"))) D Q:$D(AG("2BPREV"))
.S (AG("CITY"),AG("2BPREV"))=$P(^AUTTCOM(AG("LKDATA"),0),U)
.S AG("HSDA")=$P(^AUTTCOM(AG("LKDATA"),0),U,11)
S DIE="^AUPNPAT("
S DA=DFN
S DR="1118///"_AG("CITY")
D ^DIE
Q
S1 ;
K DFOUT,DTOUT,DUOUT,DLOUT,DQOUT
Q
COMMVER ;EP
S AG("COMMVER")=" "
S:$D(^AUPNPAT(DFN,11)) AG("COMMVER")=$P(^AUPNPAT(DFN,11),U,21)
W !!,"Has this COMMUNITY been VERIFIED? (Y/N): "
W:(AG("COMMVER")["Y")!(AG("COMMVER")["N") AG("COMMVER")," // "
D READ^AG
S:$D(DLOUT)&(AG("COMMVER")'=" ") Y=AG("COMMVER")
S AG("COMAGED1")=Y
I "YC"[AGOPT(14),$D(AG("SEL")),AG("SEL")="6" D
. S DIE="^AUPNPAT("
. S DA=DFN
. S DR="1121///"_AG("COMAGED1")
. D ^DIE
. D ^AGBIC2C
Q
AGBIC2B ; IHS/ASDS/EFG - ENTER CURRENT COMMUNITY ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
L1 ;
+1 KILL AG("HSDA"),AG("PRVCM"),AG("COMM")
+2 WRITE !!,"Enter PRESENT COMMUNITY: "
+3 DO DEF
+4 DO READ^AG
+5 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
GOTO END
+6 IF $DATA(DLOUT)&($DATA(AG("EDIT")))&($DATA(AG("PRVCM")))
Begin DoDot:1
+7 SET Y=AG("PRVCM")
End DoDot:1
GOTO L2
+8 IF $DATA(DLOUT)!$DATA(DQOUT)
SET Y="?"
L2 ;
+1 SET DIC="^AUTTCOM("
+2 SET DIC(0)="QEM"
+3 SET X=Y
+4 DO ^DIC
+5 IF Y<0
GOTO L1
+6 SET AG("CPTR")=+Y
+7 SET AG("CITY")=$PIECE(Y,U,2)
+8 IF $PIECE(^AUTTCTY($PIECE(^AUTTCOM($PIECE(Y,U),0),U,2),0),U,5)="Y"
SET AG("HSDA")="Y"
L3 ;
+1 KILL AG("EDIT"),AG("BIRTH"),AG("PRVDT")
+2 WRITE !!,"When did the patient move to this community? "
+3 WRITE "( ""B"" = ""at BIRTH"" ) ",!," DATE: "
+4 DO DEF1
+5 DO READ^AG
+6 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+7 IF $DATA(DUOUT)
GOTO L1
+8 IF $DATA(DLOUT)&($DATA(AG("EDIT")))&($DATA(AG("PRVDT")))
Begin DoDot:1
+9 SET Y=AG("PRVDT")
End DoDot:1
GOTO L3A
+10 IF $DATA(DLOUT)!$DATA(DQOUT)
SET Y="?"
L3A ;
+1 IF Y="B"
Begin DoDot:1
+2 SET AG("BIRTH")=""
+3 SET DIC=2
+4 SET DA=DFN
+5 SET DR=.03
+6 DO ^DIC
+7 IF $DATA(AG("LKDATA"))
SET Y=AG("LKDATA")
+8 IF $DATA(AG("LKERR"))!($DATA(AG("LKDATA"))&(+Y<99999))
Begin DoDot:2
+9 WRITE !,*7,"There is no DATE-OF-BIRTH on file.",!
+10 SET Y="?"
+11 KILL AG("BIRTH")
End DoDot:2
End DoDot:1
+12 SET X=Y
+13 SET %DT=""
+14 SET %DT(0)="-NOW"
+15 DO ^%DT
+16 KILL %DT(0)
+17 IF X="^"
GOTO L1
+18 IF $DATA(AG("EDIT"))&(X="")
GOTO END
+19 IF Y<0
GOTO L3
+20 SET AG("CDATE")=Y
L4 ;
+1 KILL ^AUPNPAT(DFN,51)
+2 SET ^AUPNPAT(DFN,51,0)="^9000001.51D^"_AG("CDATE")_"^1"
+3 SET ^AUPNPAT(DFN,51,AG("CDATE"),0)=AG("CDATE")_U_DT_U_AG("CPTR")
+4 SET DIE="^AUPNPAT("
+5 SET DA=DFN
+6 SET DR="1118///"_AG("CITY")
+7 DO ^DIE
CKHSDA ;
+1 SET AG("COMM")="N"
+2 IF '$DATA(AG("HSDA"))
GOTO STCOMVER
+3 DO COMMVER
+4 IF $DATA(DUOUT)
GOTO L3
+5 IF (Y'["Y")&(Y'["N")
Begin DoDot:1
+6 DO YN^AG
End DoDot:1
GOTO CKHSDA
+7 SET AG("COMM")=Y
STCOMVER ;
+1 DO S1
+2 SET DR="1121///"_AG("COMM")
+3 DO ^DIE
+4 IF AG("COMM")="Y"
GOTO END
CKPREV ;
+1 IF $DATA(AG("BIRTH"))
GOTO END
+2 IF AG("CDATE")>"2880915"
GOTO END
+3 WRITE !!,"This patient's CURRENT COMMUNITY is "
+4 WRITE $SELECT('$DATA(AG("HSDA")):"not within a HSDA!",1:"within a HSDA but is not verified!")
MSG1 ;
+1 WRITE !,"Enter any other COMMUNITY lived in since 09/16/88: "
+2 SET AG("COMM")="N"
+3 SET AG("2BPREV")=""
+4 DO READ^AG
+5 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
GOTO END
+6 KILL AG("2BPREV")
+7 SET DIC="^AUTTCOM("
+8 SET DIC(0)="QEM"
+9 SET X=Y
+10 DO ^DIC
+11 IF Y<0
GOTO END
+12 IF $PIECE(^AUTTCTY($PIECE(^AUTTCOM($PIECE(Y,U),0),U,2),0),U,5)'="Y"
Begin DoDot:1
+13 WRITE !!,$PIECE(^AUTTCOM($PIECE(Y,U),0),U)," is not within a HSDA!"
End DoDot:1
GOTO MSG1
CKPRVER ;
+1 DO COMMVER
+2 IF $DATA(DUOUT)!(Y["N")
GOTO CKPREV
+3 IF Y'["Y"
Begin DoDot:1
+4 DO YN^AG
End DoDot:1
GOTO CKPRVER
+5 SET AG("COMM")="Y"
SETPRV ;
+1 DO S1
+2 SET DR="1122///"_AG("COMM")
+3 DO ^DIE
+4 GOTO END
END ;
+1 KILL AG("COMMVER"),AG("BIRTH"),AG("HSDA"),AG("PRVDT"),AG("PRVCM")
+2 KILL AG("COMM"),DIC
+3 QUIT
DEF ;
+1 KILL AG("EDIT")
+2 IF '$DATA(^AUPNPAT(DFN,51,0))
QUIT
+3 SET AG("CDATE")=$PIECE(^AUPNPAT(DFN,51,0),U,3)
+4 IF AG("CDATE")=""
QUIT
+5 IF '$DATA(^AUPNPAT(DFN,51,AG("CDATE")))
QUIT
+6 SET AG("CPTR")=$PIECE(^AUPNPAT(DFN,51,AG("CDATE"),0),U,3)
+7 IF +AG("CPTR")<1
QUIT
+8 IF '$DATA(^AUTTCOM(AG("CPTR")))
QUIT
+9 WRITE $PIECE(^AUTTCOM(AG("CPTR"),0),U),"//"
+10 SET AG("EDIT")=""
+11 SET AG("PRVCM")=$PIECE(^AUTTCOM(AG("CPTR"),0),U)
+12 QUIT
DEF1 ;
+1 KILL AG("EDIT")
+2 IF $DATA(^AUPNPAT(DFN,51,0))
IF AG("CDATE")]""
Begin DoDot:1
+3 SET Y=$PIECE(^AUPNPAT(DFN,51,AG("CDATE"),0),U)
+4 DO DD^%DT
+5 WRITE !,Y,"// "
+6 SET AG("EDIT")=""
+7 SET AG("PRVDT")=Y
End DoDot:1
+8 QUIT
EDCOM ;EP - Edit Communities.
E1 ;
+1 KILL DIC("S")
+2 SET DIC=9000001.51
+3 SET DR=.01
+4 SET X=DFN
+5 DO ^DIC
+6 SET DA=+Y
+7 SET DIE="^AUPNPAT("
+8 SET DR=5101
+9 SET DR(2,9000001.51)=".01;.03;S $P(^AUPNPAT(DFN,51,D1,0),U,2)=$P(^AUPNPAT(DFN,51,D1,0),U)"
+10 DO ^DIE
E2 ;
+1 SET AG("DRENT")=0
+2 SET DR=.03
+3 SET AG("CITY")=""
+4 SET DIC=9000001.51
+5 SET DA=DFN
+6 DO ^DIC
+7 IF $DATA(AG("LKDATA"))
IF AG("LKDATA")]""
IF $DATA(^AUTTCOM(AG("LKDATA")))
Begin DoDot:1
+8 SET (AG("CITY"),AG("2BPREV"))=$PIECE(^AUTTCOM(AG("LKDATA"),0),U)
+9 SET AG("HSDA")=$PIECE(^AUTTCOM(AG("LKDATA"),0),U,11)
End DoDot:1
IF $DATA(AG("2BPREV"))
QUIT
+10 SET DIE="^AUPNPAT("
+11 SET DA=DFN
+12 SET DR="1118///"_AG("CITY")
+13 DO ^DIE
+14 QUIT
S1 ;
+1 KILL DFOUT,DTOUT,DUOUT,DLOUT,DQOUT
+2 QUIT
COMMVER ;EP
+1 SET AG("COMMVER")=" "
+2 IF $DATA(^AUPNPAT(DFN,11))
SET AG("COMMVER")=$PIECE(^AUPNPAT(DFN,11),U,21)
+3 WRITE !!,"Has this COMMUNITY been VERIFIED? (Y/N): "
+4 IF (AG("COMMVER")["Y")!(AG("COMMVER")["N")
WRITE AG("COMMVER")," // "
+5 DO READ^AG
+6 IF $DATA(DLOUT)&(AG("COMMVER")'=" ")
SET Y=AG("COMMVER")
+7 SET AG("COMAGED1")=Y
+8 IF "YC"[AGOPT(14)
IF $DATA(AG("SEL"))
IF AG("SEL")="6"
Begin DoDot:1
+9 SET DIE="^AUPNPAT("
+10 SET DA=DFN
+11 SET DR="1121///"_AG("COMAGED1")
+12 DO ^DIE
+13 DO ^AGBIC2C
End DoDot:1
+14 QUIT
