- 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
