AGVALID ; IHS/ASDS/EFG - PATIENTS WITH INVALID PRIMARY DATA ;
;;7.1;PATIENT REGISTRATION;**5**;AUG 25,2005
;
S AGIO=IO,AG("HAT")=""
DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS Q
G:'$D(IO("Q")) START K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
X ^%ZOSF("UCI") S ZTRTN="START^AGVALID",ZTUCI=Y,ZTDESC="PATIENTS WITH INVALID DATA for "_$P(^AUTTLOC(DUZ(2),0),U,2)_".",ZTSAVE=""
D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGIO,ZTDESC,ZTRTN,ZTSK,ZTUCI D ^%ZISC
Q
START ;EP - From TaskMan.
S (DFN,AGPGPG,AGTOTAL)=0
S X=$P(^DIC(4,DUZ(2),0),U) D CTR^AG
S AG("LOC")=X,AG("USR")=$P(^VA(200,DUZ,0),U)
S AG("LINE")="="
S AGBM=IOSL-10
I $D(AGIO),AGIO=IO S AGBM=IOSL-4
X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",") D CTR^AG S AGUCI=X
U IO D NOW^AG S X="as of "_AGTIME D CTR^AG S AGTIME=X D HDR
B2 S DFN=$O(^DPT(DFN))
G END:DFN]"@",B2:'$D(^AUPNPAT(DFN,41,DUZ(2),0)),B2:$P(^(0),U,3)]""
S DA=DFN
F AG=1,6,12,19,28,36,51,57,64,71 S AGTAB(AG)=1
I $D(^DPT(DFN,0)) D
.S:$P(^(0),U,3)]"" AGTAB(1)=0
.S:$P(^(0),U,2)]"" AGTAB(6)=0 ;DOB & SEX
I $D(^AUPNPAT(DFN,11)) D
.I $P(^AUPNPAT(DFN,11),U,8)]"",$D(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8))) D
..S AGTAB(12)=0 ;Tribe Of Membership
I $D(^AUPNPAT(DFN,11)) D
.;Indian Blood Quantum & Current Community
.S:$P(^(11),U,10)]"" AGTAB(19)=0
.S:$P(^(11),U,18)]"" AGTAB(28)=0
I $D(^AUPNPAT(DFN,11)),$P(^(11),U,11)]"",$D(^AUTTBEN($P(^(11),U,11))) D
.S AGTAB(36)=0 ;Classification/Beneficiary
;mailing address
I $D(^DPT(DFN,.11)) D
.S AGR=$G(^DPT(DFN,.11))
.I $P(AGR,U)]"",$P(AGR,U,4)]"",$P(AGR,U,5)]"",$P(AGR,U,6)]"" S AGTAB(64)=0
;emergency contact
I $D(^DPT(DFN,.33)) D
.S AGR=$G(^DPT(DFN,.33))
.S $P(AGR,U,2)=$P($G(^AUPNPAT(DFN,31)),U,2) ;IHS/SD/TPF 5/13/2009 AG*7.1*5 H4639
.I $P(AGR,U)]"",$P(AGR,U,2)]"",$P(AGR,U,3)]"",$P(AGR,U,6)]"",$P(AGR,U,7)]"",$P(AGR,U,8)]"",$P(AGR,U,9)]"" S AGTAB(57)=0
;next of kin
I $D(^DPT(DFN,.21)) D
.S AGR=$G(^DPT(DFN,.21))
.I $P(AGR,U)]"" S AGTAB(51)=0
;home phone
I $D(^DPT(DFN,.13)) D
.I $P(^DPT(DFN,.13),U)]"" S AGTAB(71)=0
WRITE ;
S (AG,AGFLAG)=""
F S AG=$O(AGTAB(AG)) Q:AG="" I $G(AGTAB(AG))=1 S AGFLAG=1 Q
F AG=1,6,12,19,28,36 D
.I $G(AGTAB(AG))="1" W ?AG,"*"
I AGFLAG W ?40,$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
F AG=51,57,64,71 D
.I $G(AGTAB(AG))="1" W ?AG,"*"
.S AGTOTAL=AGTOTAL+1
I $G(AGFLAG)=1 W !
I $Y>AGBM D RTRN^AG G:$D(DUOUT)!$D(DTOUT)!$D(DTOUT) KILL D HDR
G B2
END W !!,"AGTOTAL FILES WITH INVALID DATA: ",AGTOTAL K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")
KILL D ^%ZISC K AG,AGBM,AGIO,AGTIME,DA,DFN,DIC,DLOUT,DR,AG("LOC"),AGPGPG,AGTAB,AGTOTAL,AGUCI,AG("USR"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD
Q
HDR S AGPGPG=AGPGPG+1 W $$S^AGVDF("IOF"),!!,AG("USR"),?72,"page ",AGPGPG
W !,AG("LOC"),!?22,"INVALID DATA ENTRIES - PATIENT FILES",!,AGUCI,!,AGTIME
W !!!!?17,"INDIAN",?25,"CURRENT",?34,"BENEF.",?49,"NOK",?55,"EMER",?62,"MAIL",?69,"HOME",!,"DOB SEX TRIBE QUANT. COMMUN. CODE CHART",?55,"CONT",?62,"ADDR",?69,"PHONE",!
D LINE^AG
Q
AGVALID ; IHS/ASDS/EFG - PATIENTS WITH INVALID PRIMARY DATA ;
+1 ;;7.1;PATIENT REGISTRATION;**5**;AUG 25,2005
+2 ;
+3 SET AGIO=IO
SET AG("HAT")=""
DEV SET %ZIS="OPQ"
DO ^%ZIS
IF POP
SET IOP=ION
DO ^%ZIS
QUIT
+1 IF '$DATA(IO("Q"))
GOTO START
KILL IO("Q")
IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+2 XECUTE ^%ZOSF("UCI")
SET ZTRTN="START^AGVALID"
SET ZTUCI=Y
SET ZTDESC="PATIENTS WITH INVALID DATA for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."
SET ZTSAVE=""
+3 DO ^%ZTLOAD
IF '$DATA(ZTSK)
GOTO DEV
KILL AG,AGIO,ZTDESC,ZTRTN,ZTSK,ZTUCI
DO ^%ZISC
+4 QUIT
START ;EP - From TaskMan.
+1 SET (DFN,AGPGPG,AGTOTAL)=0
+2 SET X=$PIECE(^DIC(4,DUZ(2),0),U)
DO CTR^AG
+3 SET AG("LOC")=X
SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)
+4 SET AG("LINE")="="
+5 SET AGBM=IOSL-10
+6 IF $DATA(AGIO)
IF AGIO=IO
SET AGBM=IOSL-4
+7 XECUTE ^%ZOSF("UCI")
SET X="UCI: "_$PIECE(Y,",")
DO CTR^AG
SET AGUCI=X
+8 USE IO
DO NOW^AG
SET X="as of "_AGTIME
DO CTR^AG
SET AGTIME=X
DO HDR
B2 SET DFN=$ORDER(^DPT(DFN))
+1 IF DFN]"@"
GOTO END
IF '$DATA(^AUPNPAT(DFN,41,DUZ(2),0))
GOTO B2
IF $PIECE(^(0),U,3)]""
GOTO B2
+2 SET DA=DFN
+3 FOR AG=1,6,12,19,28,36,51,57,64,71
SET AGTAB(AG)=1
+4 IF $DATA(^DPT(DFN,0))
Begin DoDot:1
+5 IF $PIECE(^(0),U,3)]""
SET AGTAB(1)=0
+6 ;DOB & SEX
IF $PIECE(^(0),U,2)]""
SET AGTAB(6)=0
End DoDot:1
+7 IF $DATA(^AUPNPAT(DFN,11))
Begin DoDot:1
+8 IF $PIECE(^AUPNPAT(DFN,11),U,8)]""
IF $DATA(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8)))
Begin DoDot:2
+9 ;Tribe Of Membership
SET AGTAB(12)=0
End DoDot:2
End DoDot:1
+10 IF $DATA(^AUPNPAT(DFN,11))
Begin DoDot:1
+11 ;Indian Blood Quantum & Current Community
+12 IF $PIECE(^(11),U,10)]""
SET AGTAB(19)=0
+13 IF $PIECE(^(11),U,18)]""
SET AGTAB(28)=0
End DoDot:1
+14 IF $DATA(^AUPNPAT(DFN,11))
IF $PIECE(^(11),U,11)]""
IF $DATA(^AUTTBEN($PIECE(^(11),U,11)))
Begin DoDot:1
+15 ;Classification/Beneficiary
SET AGTAB(36)=0
End DoDot:1
+16 ;mailing address
+17 IF $DATA(^DPT(DFN,.11))
Begin DoDot:1
+18 SET AGR=$GET(^DPT(DFN,.11))
+19 IF $PIECE(AGR,U)]""
IF $PIECE(AGR,U,4)]""
IF $PIECE(AGR,U,5)]""
IF $PIECE(AGR,U,6)]""
SET AGTAB(64)=0
End DoDot:1
+20 ;emergency contact
+21 IF $DATA(^DPT(DFN,.33))
Begin DoDot:1
+22 SET AGR=$GET(^DPT(DFN,.33))
+23 ;IHS/SD/TPF 5/13/2009 AG*7.1*5 H4639
SET $PIECE(AGR,U,2)=$PIECE($GET(^AUPNPAT(DFN,31)),U,2)
+24 IF $PIECE(AGR,U)]""
IF $PIECE(AGR,U,2)]""
IF $PIECE(AGR,U,3)]""
IF $PIECE(AGR,U,6)]""
IF $PIECE(AGR,U,7)]""
IF $PIECE(AGR,U,8)]""
IF $PIECE(AGR,U,9)]""
SET AGTAB(57)=0
End DoDot:1
+25 ;next of kin
+26 IF $DATA(^DPT(DFN,.21))
Begin DoDot:1
+27 SET AGR=$GET(^DPT(DFN,.21))
+28 IF $PIECE(AGR,U)]""
SET AGTAB(51)=0
End DoDot:1
+29 ;home phone
+30 IF $DATA(^DPT(DFN,.13))
Begin DoDot:1
+31 IF $PIECE(^DPT(DFN,.13),U)]""
SET AGTAB(71)=0
End DoDot:1
WRITE ;
+1 SET (AG,AGFLAG)=""
+2 FOR
SET AG=$ORDER(AGTAB(AG))
IF AG=""
QUIT
IF $GET(AGTAB(AG))=1
SET AGFLAG=1
QUIT
+3 FOR AG=1,6,12,19,28,36
Begin DoDot:1
+4 IF $GET(AGTAB(AG))="1"
WRITE ?AG,"*"
End DoDot:1
+5 IF AGFLAG
WRITE ?40,$PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2)
+6 FOR AG=51,57,64,71
Begin DoDot:1
+7 IF $GET(AGTAB(AG))="1"
WRITE ?AG,"*"
+8 SET AGTOTAL=AGTOTAL+1
End DoDot:1
+9 IF $GET(AGFLAG)=1
WRITE !
+10 IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DTOUT)
GOTO KILL
DO HDR
+11 GOTO B2
END WRITE !!,"AGTOTAL FILES WITH INVALID DATA: ",AGTOTAL
KILL AG("HAT")
DO RTRN^AG
WRITE $$S^AGVDF("IOF")
KILL DO ^%ZISC
KILL AG,AGBM,AGIO,AGTIME,DA,DFN,DIC,DLOUT,DR,AG("LOC"),AGPGPG,AGTAB,AGTOTAL,AGUCI,AG("USR"),X,Y
IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 QUIT
HDR SET AGPGPG=AGPGPG+1
WRITE $$S^AGVDF("IOF"),!!,AG("USR"),?72,"page ",AGPGPG
+1 WRITE !,AG("LOC"),!?22,"INVALID DATA ENTRIES - PATIENT FILES",!,AGUCI,!,AGTIME
+2 WRITE !!!!?17,"INDIAN",?25,"CURRENT",?34,"BENEF.",?49,"NOK",?55,"EMER",?62,"MAIL",?69,"HOME",!,"DOB SEX TRIBE QUANT. COMMUN. CODE CHART",?55,"CONT",?62,"ADDR",?69,"PHONE",!
+3 DO LINE^AG
+4 QUIT
