- 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
