AG2B ; IHS/ASDS/EFG - ENTER COMMUNITY OF RESIDENCE DATA ;
;;7.1;PATIENT REGISTRATION;**8**;AUG 25, 2005
;
L1 ;
W !!,"Enter PRESENT COMMUNITY: "
D DEF
D READ^AG
Q:$D(DUOUT)!$D(DTOUT)!$D(DFOUT)
G L3:$D(DLOUT)&$D(AG("EDIT"))
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)
L3 ;
K AG("EDIT")
W !!,"When did the patient move to this community? "
W "( ""B"" = ""at BIRTH"" ) "
W !," DATE: "
D DEF1
D READ^AG
Q:$D(DTOUT)!$D(DFOUT)
G L1:$D(DUOUT),END:$D(DLOUT)&($D(AG("EDIT")))
I $D(DLOUT)!$D(DQOUT) S Y="?"
L3A ;
I Y="B" D
. S DIC=2
. S DA=DFN
. S DR=.03
. D ^AGDICLK
. S:$D(AG("LKDATA")) Y=AG("LKDATA")
. I $G(AG("LKERR"))!($D(AG("LKDATA"))&(+Y<99999)) D
.. W !,*7,"There is no DATE-OF-BIRTH on file.",!
.. S Y="?"
S X=Y
S %DT=""
S %DT(0)="-NOW"
D ^%DT
K %DT(0)
G L1:X="^",END:$D(AG("EDIT"))&(X=""),L3:Y<0
S AG("CDATE")=Y
L4 ;
S DIC("P")=9000001.51,DIC="^AUPNPAT("_DFN_",51,",DIC(0)="QML",(DINUM,X)=AG("CDATE"),DA(1)=DFN,DIC("DR")=".02////"_DT_";.03////"_AG("CPTR") K DD,DO D FILE^DICN
END ;
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")=""
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")=""
Q
EDCOM ;EP - Edit Communities (string in AGED1 and AGBICEDZ).
I AGOPT(14)'="N" D Q
. D EDCOM^AGBIC2B
. D COMMVER^AGBIC2B
. D CMMNR^AGBIC2
;
;Get before picture of community information
D GETS^DIQ(9000001,DFN_",","5101*","I","OCOM")
;
E1 ;
K DIC("S")
S DIE="^AUPNPAT("
S DA=DFN
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
;
;Verify that an entry is present - AG*7.1*8
I $O(^AUPNPAT(DFN,51,0))="",'$D(Y) W "?? Required" G E1
Q
AG2B ; IHS/ASDS/EFG - ENTER COMMUNITY OF RESIDENCE DATA ;
+1 ;;7.1;PATIENT REGISTRATION;**8**;AUG 25, 2005
+2 ;
L1 ;
+1 WRITE !!,"Enter PRESENT COMMUNITY: "
+2 DO DEF
+3 DO READ^AG
+4 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
QUIT
+5 IF $DATA(DLOUT)&$DATA(AG("EDIT"))
GOTO L3
+6 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)
L3 ;
+1 KILL AG("EDIT")
+2 WRITE !!,"When did the patient move to this community? "
+3 WRITE "( ""B"" = ""at BIRTH"" ) "
+4 WRITE !," DATE: "
+5 DO DEF1
+6 DO READ^AG
+7 IF $DATA(DTOUT)!$DATA(DFOUT)
QUIT
+8 IF $DATA(DUOUT)
GOTO L1
IF $DATA(DLOUT)&($DATA(AG("EDIT")))
GOTO END
+9 IF $DATA(DLOUT)!$DATA(DQOUT)
SET Y="?"
L3A ;
+1 IF Y="B"
Begin DoDot:1
+2 SET DIC=2
+3 SET DA=DFN
+4 SET DR=.03
+5 DO ^AGDICLK
+6 IF $DATA(AG("LKDATA"))
SET Y=AG("LKDATA")
+7 IF $GET(AG("LKERR"))!($DATA(AG("LKDATA"))&(+Y<99999))
Begin DoDot:2
+8 WRITE !,*7,"There is no DATE-OF-BIRTH on file.",!
+9 SET Y="?"
End DoDot:2
End DoDot:1
+10 SET X=Y
+11 SET %DT=""
+12 SET %DT(0)="-NOW"
+13 DO ^%DT
+14 KILL %DT(0)
+15 IF X="^"
GOTO L1
IF $DATA(AG("EDIT"))&(X="")
GOTO END
IF Y<0
GOTO L3
+16 SET AG("CDATE")=Y
L4 ;
+1 SET DIC("P")=9000001.51
SET DIC="^AUPNPAT("_DFN_",51,"
SET DIC(0)="QML"
SET (DINUM,X)=AG("CDATE")
SET DA(1)=DFN
SET DIC("DR")=".02////"_DT_";.03////"_AG("CPTR")
KILL DD,DO
DO FILE^DICN
END ;
+1 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 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")=""
End DoDot:1
+7 QUIT
EDCOM ;EP - Edit Communities (string in AGED1 and AGBICEDZ).
+1 IF AGOPT(14)'="N"
Begin DoDot:1
+2 DO EDCOM^AGBIC2B
+3 DO COMMVER^AGBIC2B
+4 DO CMMNR^AGBIC2
End DoDot:1
QUIT
+5 ;
+6 ;Get before picture of community information
+7 DO GETS^DIQ(9000001,DFN_",","5101*","I","OCOM")
+8 ;
E1 ;
+1 KILL DIC("S")
+2 SET DIE="^AUPNPAT("
+3 SET DA=DFN
+4 SET DR=5101
+5 SET DR(2,9000001.51)=".01;.03;S $P(^AUPNPAT(DFN,51,D1,0),U,2)=$P(^AUPNPAT(DFN,51,D1,0),U)"
+6 DO ^DIE
+7 ;
+8 ;Verify that an entry is present - AG*7.1*8
+9 IF $ORDER(^AUPNPAT(DFN,51,0))=""
IF '$DATA(Y)
WRITE "?? Required"
GOTO E1
+10 QUIT
