- 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
