AGCMATCH ; IHS/ASDS/SDH-Patient Registration ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
;This report is used for checking blank community, blank mailing
;address city, and it they don't match. Also checks if these fields
;contain "unknown" anything.
;
S AGALL=""
S (AGCNT1,AGCNT2,AGCNT3)=0
W !!,"WARNING: "
W !,"COMPLETE REPORT COULD BE LARGE DEPENDING ON THE SIZE OF YOUR FACILITY!!"
W !,"It is recommended that Medical Records Staff print this report to a capture file on a PC, and not to a printer!"
W !,"Please see the release notes for patch 13 and consult your Site Manager for assistance in printing to a capture file."
S DIR(0)="S^C:COMPLETE(BLANKS, MISMATCHES, AND UNKNOWNS)"
S DIR(0)=DIR(0)_";B:BLANKS ONLY"
S DIR(0)=DIR(0)_";U:UNKNOWNS ONLY (ALSO INCLUDES ""OTH"")"
S DIR(0)=DIR(0)_";A:BOTH BLANKS AND UNKNOWNS"
S DIR("A")="WHICH REPORT WOULD YOU LIKE "
S DIR("B")="B"
D ^DIR K DIR
Q:$D(DIRUT)!$D(DIROUT)!$D(DTOUT)
S AGALL=Y
D ^%ZIS
Q:POP
S AGBM=IOSL-4
U IO
N AGADDR,AGMAIL,AGCNT
S U="^"
S AGNAME=""
S AG1=""
S AGFLAG1=""
S AGPAGE=1
F S AG1=$O(^DPT("B",AG1)) Q:AG1=""!AGFLAG1 D
.S AG2=0
.F S AG2=$O(^DPT("B",AG1,AG2)) Q:'AG2!AGFLAG1 D
..S AGWFLG=""
..S AGEFLG=0,AGERROR=0
..D AGCHECK ;checks if they have HRN
..I $D(HRN),HRN["T" Q ;check if temp numbers are included
..I AGFLAG=0 Q
..S AGNAME=$P($G(^DPT(AG2,0)),U)
..I AGNAME'=AG1 Q ;makes sure names match
..S AGCOMM=$P($G(^AUPNPAT(AG2,11)),U,18) ;current community
..S AGADDR=$P($G(^DPT(AG2,.11)),U,4) ;mailing address city
..I AGALL="C" D ;if complete
...I AGCOMM=""!(AGADDR="")!(AGCOMM["UNK")!(AGCOMM["OTH")!(AGCOMM'=AGADDR) D Q
....I AGCOMM'="",AGADDR'="",AGCOMM'=AGADDR S AGERROR=3,AGEFLG=1
....I AGCOMM=""!(AGADDR="") S AGERROR=1,AGEFLG=AGEFLG+1
....I AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH") S AGERROR=2,AGEFLG=AGEFLG+1
....I AGEFLG>1 D ERRCHK ;if there is more than one error
....D SAVE
..I AGALL="B",((AGCOMM="")!(AGADDR="")) D Q ;blank
...S AGERROR=1
...D SAVE
..;if unknowns
..I AGALL="U",(AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH")) D Q
...S AGERROR=2
...D SAVE
..;blanks&unknowns
..I AGALL="A" D
...I (AGCOMM="")!(AGADDR="")!(AGCOMM["UNK")!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH") D Q
....I AGCOMM=""!(AGADDR="") S AGERROR=1
....I AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH") S AGERROR=2
....D SAVE
D WRITE
D ^%ZISC
K AGNAME,AG2,AGCOMM,AGADDR,AGFLAG1,AGPAGE,AGWFLG
K AGCNT1,AGCNT2,AGCNT3,TOT
Q
ERRCHK ;if more than one error sets priority error
I AGADDR="" S AGERROR=1 Q
I AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH") S AGERROR=2 Q
I AGCOMM]"",AGADDR]"",AGCOMM'=AGADDR S AGERROR=3
Q
SAVE ;
I HRN="" S HRN="NO HRN"
S AGINACT=$P($G(^AUPNPAT(AG2,41,AGDUZ2,0)),U,3) ;inactive/deleted
S AGDOD=$P($G(^DPT(AG2,.35)),U) ;date of death
I $G(AGINACT)'=""!($G(AGDOD)'="") S AGADD="I"
E S AGADD="A"
I AGCOMM="" S AGCOMM="AANONE"
S ^AGTMP($J,AGERROR,AGCOMM,AGADD,AGNAME,HRN)=AGADDR
I AGERROR=1 S AGCNT1=AGCNT1+1
I AGERROR=2 S AGCNT2=AGCNT2+1
I AGERROR=3 S AGCNT3=AGCNT3+1
S AGWFLG=1
Q
WRITE ;writes record to temp global if condition is met. Also checks
;for active/inactive status of patient; checks for new page/header.
;
D HDR
S (AGER,AGHRN,AGNM,AGADD,AGCOM,AGADDR)=""
F S AGER=$O(^AGTMP($J,AGER)) Q:AGER=""!AGFLAG1 D
.I AGER=1 W !,"BLANK CITY/COMMUNITY",!
.I AGER=2 W !,"UNKNOWN/OTHER",!
.I AGER=3 W !,"MISMATCHES",!
.F S AGCOM=$O(^AGTMP($J,AGER,AGCOM)) Q:AGCOM=""!AGFLAG1 D
..F S AGADD=$O(^AGTMP($J,AGER,AGCOM,AGADD)) Q:AGADD=""!AGFLAG1 D
...F S AGNM=$O(^AGTMP($J,AGER,AGCOM,AGADD,AGNM)) Q:AGNM=""!AGFLAG1 D
....F S AGHRN=$O(^AGTMP($J,AGER,AGCOM,AGADD,AGNM,AGHRN)) Q:AGHRN=""!AGFLAG1 D
.....S AGREC=$G(^AGTMP($J,AGER,AGCOM,AGADD,AGNM,AGHRN))
.....S AGADDR=$P(AGREC,U)
.....I AGCOM["AANONE" S AGCOMM=""
.....E S AGCOMM=AGCOM
.....W ?3,AGNM
.....W ?27,AGADD
.....W ?31,AGHRN
.....W ?40,AGADDR
.....W ?60,AGCOMM
.....W !
.....I $Y>AGBM D
......D RTRN^AG
......I $D(DUOUT)!$D(DTOUT)!$D(DFOUT) S AGFLAG1=1 Q
......D HDR
.I 'AGFLAG1 D
..F Z=1:1:80 W "-"
..W !
W !!,"*** END OF REPORT ***",!!
I IO["C" D
.S DIR(0)="E"
.S DIR("A")="ENTER RETURN TO CONTINUE"
.D ^DIR
K ^AGTMP($J)
Q
HDR ;
S TOT=0
D NOW^%DTC
D YX^%DTC
S DATE=$P(Y,"@")
W $$S^AGVDF("IOF")
S X=DATE_" COMMUNITY/CITY MISMATCH REPORT Page "_AGPAGE
D CTR^AG
W !,X
S X=$P(^AUTTLOC(DUZ(2),0),U,2)
D CTR^AG
W !,X
I AGALL="C" S AGALL="BUM"
I AGALL="A" S AGALL="BU"
I AGPAGE=1 D
.W !!,"This report contains "
.I AGALL["B" D ;blanks
..W !?10,"BLANKS",?20,$J(+$G(AGCNT1),10)
..S TOT=TOT+AGCNT1
.I AGALL["U" D ;unknowns
..W !?10,"UNKNOWNS",?20,$J(+$G(AGCNT2),10)
..S TOT=TOT+AGCNT2
.I AGALL["M" D ;mismatches
..W !?10,"MISMATCHES",?20,$J(+$G(AGCNT3),10)
..S TOT=TOT+AGCNT3
.W !?10,"TOTAL: ",?20,$J(TOT,10)
W !!?3,"NAME",?26,"A/I",?31,"HRN",?40,"MAIL.ADDR-CITY",?60,"CURRENT COMM",!
F AG=1:1:80 W "="
W !
S AGPAGE=AGPAGE+1
Q
AGCHECK ;
;looks that they have an HRN
S AGFLAG=0
S AGDUZ2=0
F S AGDUZ2=$O(^AUPNPAT(AG2,41,AGDUZ2)) Q:AGDUZ2="" D Q:AGFLAG
.I AGDUZ2=DUZ(2) S HRN=$P($G(^AUPNPAT(AG2,41,AGDUZ2,0)),U,2),AGFLAG=1 Q
Q
AGCMATCH ; IHS/ASDS/SDH-Patient Registration ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
+3 ;This report is used for checking blank community, blank mailing
+4 ;address city, and it they don't match. Also checks if these fields
+5 ;contain "unknown" anything.
+6 ;
+7 SET AGALL=""
+8 SET (AGCNT1,AGCNT2,AGCNT3)=0
+9 WRITE !!,"WARNING: "
+10 WRITE !,"COMPLETE REPORT COULD BE LARGE DEPENDING ON THE SIZE OF YOUR FACILITY!!"
+11 WRITE !,"It is recommended that Medical Records Staff print this report to a capture file on a PC, and not to a printer!"
+12 WRITE !,"Please see the release notes for patch 13 and consult your Site Manager for assistance in printing to a capture file."
+13 SET DIR(0)="S^C:COMPLETE(BLANKS, MISMATCHES, AND UNKNOWNS)"
+14 SET DIR(0)=DIR(0)_";B:BLANKS ONLY"
+15 SET DIR(0)=DIR(0)_";U:UNKNOWNS ONLY (ALSO INCLUDES ""OTH"")"
+16 SET DIR(0)=DIR(0)_";A:BOTH BLANKS AND UNKNOWNS"
+17 SET DIR("A")="WHICH REPORT WOULD YOU LIKE "
+18 SET DIR("B")="B"
+19 DO ^DIR
KILL DIR
+20 IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)
QUIT
+21 SET AGALL=Y
+22 DO ^%ZIS
+23 IF POP
QUIT
+24 SET AGBM=IOSL-4
+25 USE IO
+26 NEW AGADDR,AGMAIL,AGCNT
+27 SET U="^"
+28 SET AGNAME=""
+29 SET AG1=""
+30 SET AGFLAG1=""
+31 SET AGPAGE=1
+32 FOR
SET AG1=$ORDER(^DPT("B",AG1))
IF AG1=""!AGFLAG1
QUIT
Begin DoDot:1
+33 SET AG2=0
+34 FOR
SET AG2=$ORDER(^DPT("B",AG1,AG2))
IF 'AG2!AGFLAG1
QUIT
Begin DoDot:2
+35 SET AGWFLG=""
+36 SET AGEFLG=0
SET AGERROR=0
+37 ;checks if they have HRN
DO AGCHECK
+38 ;check if temp numbers are included
IF $DATA(HRN)
IF HRN["T"
QUIT
+39 IF AGFLAG=0
QUIT
+40 SET AGNAME=$PIECE($GET(^DPT(AG2,0)),U)
+41 ;makes sure names match
IF AGNAME'=AG1
QUIT
+42 ;current community
SET AGCOMM=$PIECE($GET(^AUPNPAT(AG2,11)),U,18)
+43 ;mailing address city
SET AGADDR=$PIECE($GET(^DPT(AG2,.11)),U,4)
+44 ;if complete
IF AGALL="C"
Begin DoDot:3
+45 IF AGCOMM=""!(AGADDR="")!(AGCOMM["UNK")!(AGCOMM["OTH")!(AGCOMM'=AGADDR)
Begin DoDot:4
+46 IF AGCOMM'=""
IF AGADDR'=""
IF AGCOMM'=AGADDR
SET AGERROR=3
SET AGEFLG=1
+47 IF AGCOMM=""!(AGADDR="")
SET AGERROR=1
SET AGEFLG=AGEFLG+1
+48 IF AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH")
SET AGERROR=2
SET AGEFLG=AGEFLG+1
+49 ;if there is more than one error
IF AGEFLG>1
DO ERRCHK
+50 DO SAVE
End DoDot:4
QUIT
End DoDot:3
+51 ;blank
IF AGALL="B"
IF ((AGCOMM="")!(AGADDR=""))
Begin DoDot:3
+52 SET AGERROR=1
+53 DO SAVE
End DoDot:3
QUIT
+54 ;if unknowns
+55 IF AGALL="U"
IF (AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH"))
Begin DoDot:3
+56 SET AGERROR=2
+57 DO SAVE
End DoDot:3
QUIT
+58 ;blanks&unknowns
+59 IF AGALL="A"
Begin DoDot:3
+60 IF (AGCOMM="")!(AGADDR="")!(AGCOMM["UNK")!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH")
Begin DoDot:4
+61 IF AGCOMM=""!(AGADDR="")
SET AGERROR=1
+62 IF AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH")
SET AGERROR=2
+63 DO SAVE
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+64 DO WRITE
+65 DO ^%ZISC
+66 KILL AGNAME,AG2,AGCOMM,AGADDR,AGFLAG1,AGPAGE,AGWFLG
+67 KILL AGCNT1,AGCNT2,AGCNT3,TOT
+68 QUIT
ERRCHK ;if more than one error sets priority error
+1 IF AGADDR=""
SET AGERROR=1
QUIT
+2 IF AGCOMM["UNK"!(AGCOMM["OTH")!(AGADDR["UNK")!(AGADDR["OTH")
SET AGERROR=2
QUIT
+3 IF AGCOMM]""
IF AGADDR]""
IF AGCOMM'=AGADDR
SET AGERROR=3
+4 QUIT
SAVE ;
+1 IF HRN=""
SET HRN="NO HRN"
+2 ;inactive/deleted
SET AGINACT=$PIECE($GET(^AUPNPAT(AG2,41,AGDUZ2,0)),U,3)
+3 ;date of death
SET AGDOD=$PIECE($GET(^DPT(AG2,.35)),U)
+4 IF $GET(AGINACT)'=""!($GET(AGDOD)'="")
SET AGADD="I"
+5 IF '$TEST
SET AGADD="A"
+6 IF AGCOMM=""
SET AGCOMM="AANONE"
+7 SET ^AGTMP($JOB,AGERROR,AGCOMM,AGADD,AGNAME,HRN)=AGADDR
+8 IF AGERROR=1
SET AGCNT1=AGCNT1+1
+9 IF AGERROR=2
SET AGCNT2=AGCNT2+1
+10 IF AGERROR=3
SET AGCNT3=AGCNT3+1
+11 SET AGWFLG=1
+12 QUIT
WRITE ;writes record to temp global if condition is met. Also checks
+1 ;for active/inactive status of patient; checks for new page/header.
+2 ;
+3 DO HDR
+4 SET (AGER,AGHRN,AGNM,AGADD,AGCOM,AGADDR)=""
+5 FOR
SET AGER=$ORDER(^AGTMP($JOB,AGER))
IF AGER=""!AGFLAG1
QUIT
Begin DoDot:1
+6 IF AGER=1
WRITE !,"BLANK CITY/COMMUNITY",!
+7 IF AGER=2
WRITE !,"UNKNOWN/OTHER",!
+8 IF AGER=3
WRITE !,"MISMATCHES",!
+9 FOR
SET AGCOM=$ORDER(^AGTMP($JOB,AGER,AGCOM))
IF AGCOM=""!AGFLAG1
QUIT
Begin DoDot:2
+10 FOR
SET AGADD=$ORDER(^AGTMP($JOB,AGER,AGCOM,AGADD))
IF AGADD=""!AGFLAG1
QUIT
Begin DoDot:3
+11 FOR
SET AGNM=$ORDER(^AGTMP($JOB,AGER,AGCOM,AGADD,AGNM))
IF AGNM=""!AGFLAG1
QUIT
Begin DoDot:4
+12 FOR
SET AGHRN=$ORDER(^AGTMP($JOB,AGER,AGCOM,AGADD,AGNM,AGHRN))
IF AGHRN=""!AGFLAG1
QUIT
Begin DoDot:5
+13 SET AGREC=$GET(^AGTMP($JOB,AGER,AGCOM,AGADD,AGNM,AGHRN))
+14 SET AGADDR=$PIECE(AGREC,U)
+15 IF AGCOM["AANONE"
SET AGCOMM=""
+16 IF '$TEST
SET AGCOMM=AGCOM
+17 WRITE ?3,AGNM
+18 WRITE ?27,AGADD
+19 WRITE ?31,AGHRN
+20 WRITE ?40,AGADDR
+21 WRITE ?60,AGCOMM
+22 WRITE !
+23 IF $Y>AGBM
Begin DoDot:6
+24 DO RTRN^AG
+25 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
SET AGFLAG1=1
QUIT
+26 DO HDR
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
+27 IF 'AGFLAG1
Begin DoDot:2
+28 FOR Z=1:1:80
WRITE "-"
+29 WRITE !
End DoDot:2
End DoDot:1
+30 WRITE !!,"*** END OF REPORT ***",!!
+31 IF IO["C"
Begin DoDot:1
+32 SET DIR(0)="E"
+33 SET DIR("A")="ENTER RETURN TO CONTINUE"
+34 DO ^DIR
End DoDot:1
+35 KILL ^AGTMP($JOB)
+36 QUIT
HDR ;
+1 SET TOT=0
+2 DO NOW^%DTC
+3 DO YX^%DTC
+4 SET DATE=$PIECE(Y,"@")
+5 WRITE $$S^AGVDF("IOF")
+6 SET X=DATE_" COMMUNITY/CITY MISMATCH REPORT Page "_AGPAGE
+7 DO CTR^AG
+8 WRITE !,X
+9 SET X=$PIECE(^AUTTLOC(DUZ(2),0),U,2)
+10 DO CTR^AG
+11 WRITE !,X
+12 IF AGALL="C"
SET AGALL="BUM"
+13 IF AGALL="A"
SET AGALL="BU"
+14 IF AGPAGE=1
Begin DoDot:1
+15 WRITE !!,"This report contains "
+16 ;blanks
IF AGALL["B"
Begin DoDot:2
+17 WRITE !?10,"BLANKS",?20,$JUSTIFY(+$GET(AGCNT1),10)
+18 SET TOT=TOT+AGCNT1
End DoDot:2
+19 ;unknowns
IF AGALL["U"
Begin DoDot:2
+20 WRITE !?10,"UNKNOWNS",?20,$JUSTIFY(+$GET(AGCNT2),10)
+21 SET TOT=TOT+AGCNT2
End DoDot:2
+22 ;mismatches
IF AGALL["M"
Begin DoDot:2
+23 WRITE !?10,"MISMATCHES",?20,$JUSTIFY(+$GET(AGCNT3),10)
+24 SET TOT=TOT+AGCNT3
End DoDot:2
+25 WRITE !?10,"TOTAL: ",?20,$JUSTIFY(TOT,10)
End DoDot:1
+26 WRITE !!?3,"NAME",?26,"A/I",?31,"HRN",?40,"MAIL.ADDR-CITY",?60,"CURRENT COMM",!
+27 FOR AG=1:1:80
WRITE "="
+28 WRITE !
+29 SET AGPAGE=AGPAGE+1
+30 QUIT
AGCHECK ;
+1 ;looks that they have an HRN
+2 SET AGFLAG=0
+3 SET AGDUZ2=0
+4 FOR
SET AGDUZ2=$ORDER(^AUPNPAT(AG2,41,AGDUZ2))
IF AGDUZ2=""
QUIT
Begin DoDot:1
+5 IF AGDUZ2=DUZ(2)
SET HRN=$PIECE($GET(^AUPNPAT(AG2,41,AGDUZ2,0)),U,2)
SET AGFLAG=1
QUIT
End DoDot:1
IF AGFLAG
QUIT
+6 QUIT
