AGRPTPDP ;IHS/SD/TPF - POTENTIAL DUPLICATE PATIENT REPORT
;;7.1;PATIENT REGISTRATION;**1,2,9**;AUG 25, 2005
;
;REPORT OF POTENTIAL DUPLICATE PATIENTS BASED ON 5 CRITERIA
;
EN ;EP
W @IOF
S RPTREQ=$P($G(^VA(200,DUZ,0)),U) ;REPORT REQUESTED BY
X ^%ZOSF("UCI")
S UCI=$P(Y,",")
S ROUTINE=$T(+0)
S:$G(AGLINE("EQ"))="" $P(AGLINE("EQ"),"=",81)=""
S:$G(AGLINE("-"))="" $P(AGLINE("-"),"-",81)=""
W !,"This report is intended to help identify duplicate patient"
W !,"records in the Registration system. The system can check"
W !,"against the following fields:"
W !!
W !,"-Last Name and First initial of Patient"
W !,"-Patient Date of Birth"
W !,"-Social Security Number"
W !,"-Current Community"
W !,"-Mother's Maiden Name"
W !!
W !,"Choose at least two factors that you wish to check against for potential"
W !,"duplicates. The system will also prompt to check over active"
W !,"locations and inactive/deceased patients."
W !
K DIR
S DIR(0)="E"
D ^DIR
ASKCRIT ;EP - ASK FOR CRITERIA
W @IOF
W !!
W !,"Please choose at least two criteria in which you want this report to run:"
S CRITERIA=""
ASKAGAIN ;EP
K DIR,DTOUT,DUOUT,DIROUT,DIRUT
I CRITERIA="" S DIR("A")="Please make a selection"
E S DIR("A")="Please make another selection"
I CRITERIA="" S DIR(0)="SO^1:NAME;2:DOB;3:SSN;4:COM;5:MAIDEN;A:ALL",DIR("B")="All"
E S DIR(0)="SO^1:NAME;2:DOB;3:SSN;4:COM;5:MAIDEN"
S DIR("L",1)="1. Last Name and First initial of Patient"
S DIR("L",2)="2. Date of Birth"
S DIR("L",3)="3. Social Security Number"
S DIR("L",4)="4. Current Community"
S DIR("L",5)="5. Mother's Maiden Name"
S DIR("L",6)=""
S DIR("L")=""
D ^DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT))
I Y'="" I CRITERIA'="",(CRITERIA[(Y_":"_Y(0))) W !,"CRITERIA ALREADY SELECTED" G ASKAGAIN
I Y="" I (CRITERIA="")!($L(CRITERIA,U)<2) W !,"NOT ENOUGH CRITERIA SELECTED!" G ASKAGAIN
I Y="",($L(CRITERIA,U)>1) D SELCRIT(CRITERIA) G ASKCRIT
I Y(0)="ALL" S CRITERIA=$P($T(CRITTXT),";;",2) D SELCRIT(CRITERIA) G ASKCRIT
I CRITERIA="" S CRITERIA=Y_":"_Y(0)
E S CRITERIA=CRITERIA_U_Y_":"_Y(0)
G ASKAGAIN
SELCRIT(CRITERIA) ;EP
A1 D SHOWCRIT(CRITERIA)
W !
K DIR
S DIR("A")="Is this correct"
S DIR("B")="Yes"
S DIR(0)="Y"
D ^DIR
Q:'Y
A2 D ASKLOC G:$D(DUOUT) A1 ;ASK IF TO INCLUDE ALL ACTIVE LOCATIONS
A3 D ASKACTDE G:$D(DUOUT) A2 ;ASK IF TO INCLUDE INACTIVE AND DECEASED PATIENTS
A4 D ASKDEV ;ASK FOR DEVICE
G:POP A3
I $G(IO("Q")) D QUE Q
U IO
D MAIN(CRITERIA)
;IF PRINTING TO A SLAVE PRINTER FREEZES UP, THE CAUSE IS THE 'CLOSE EXECUTE' IN
;THE 'TERMINAL TYPE' FILE IS NOT FILLED IN FOR THE 'SUBTYPE' OF THE SLAVE
;DEVICE CHOSEN.
D ^%ZISC
Q
ASKDEV ;EP
S %ZIS="Q"
D ^%ZIS
Q
ASKLOC ;EP
S ALLLOC=0
K DIR
S DIR("A")="Do you wish to include across all active locations"
S DIR("B")="Yes"
S DIR(0)="Y"
D ^DIR
S ALLLOC=+Y
Q
ASKACTDE ;EP
S INCACTDE=0
K DIR
S DIR("A")="Do you wish to include inactive or deceased patients"
S DIR("B")="No"
S DIR(0)="Y"
D ^DIR
S INCACTDE=+Y
Q
MAIN(CRITERIA) ;MAIN
K ^XTMP(ROUTINE)
D NOW^%DTC S Y=% X ^DD("DD")
S RPTDATE=Y
S (LASTINI,DOB,SSN,COM,MAIDEN)=""
S PATIEN=0
F S PATIEN=$O(^AUPNPAT(PATIEN)) Q:+PATIEN=0 D
.S DECEASE=$$CHKDEATH^AGEDERR(PATIEN)
.I 'INCACTDE Q:DECEASE ;INCLUDE DECEASE AND INACTIVE IS NO QUIT
.I CRITERIA[("NAME") D
..S NAME=$P($G(^DPT(PATIEN,0)),U)
..S LASTNAME=$P(NAME,",")
..S FIRSTINI=$E($P(NAME,",",2))
..S LASTINI=LASTNAME_" "_FIRSTINI
.I CRITERIA[("DOB") D
..S DOB=$P($G(^DPT(PATIEN,0)),U,3)
.I CRITERIA[("SSN") D
..S SSN=$P($G(^DPT(PATIEN,0)),U,9)
.I CRITERIA[("COM") D
..S COM=$P($G(^AUPNPAT(PATIEN,11)),U,18) ;FREE TEXT - NOT A GOOD CRITERIA
.I CRITERIA[("MAIDEN") D
..S MAIDEN=$P($G(^DPT(PATIEN,.24)),U,3) ;FREE TEXT - NOT A GOOD CRITERIA
.S FUNNYSUB=LASTINI_U_DOB_U_SSN_U_COM_U_MAIDEN
.S ^XTMP(ROUTINE,$J,FUNNYSUB,PATIEN)=""
.S ^XTMP(ROUTINE,$J,FUNNYSUB)=$G(^XTMP(ROUTINE,$J,FUNNYSUB))+1
W !,"DUPLICATE CHECK COMPLETE "
D REPORT(CRITERIA)
Q
REPORT(CRITERIA) ;EP
S PAGE=0
S ESCAPE=0
D HDR(CRITERIA)
S FUNNYSUB=""
F S FUNNYSUB=$O(^XTMP(ROUTINE,$J,FUNNYSUB)) Q:FUNNYSUB="" D Q:ESCAPE
.S PATIEN=""
.F LN1=1:1 S PATIEN=$O(^XTMP(ROUTINE,$J,FUNNYSUB,PATIEN)) Q:PATIEN="" D Q:ESCAPE
..Q:$G(^XTMP(ROUTINE,$J,FUNNYSUB))<2
..S PATNAME=$P($G(^DPT(PATIEN,0)),U)
..S DECEASE=$$CHKDEATH^AGEDERR(PATIEN)
..S PATDOB=$P($G(^DPT(PATIEN,0)),U,3)
..I PATDOB'="" S Y=PATDOB X ^DD("DD") S PATDOB=Y
..E S PATDOB="<none>"
..S MAIDEN=$P($G(^DPT(PATIEN,.24)),U,3)
..S CURCOM=$P($G(^AUPNPAT(PATIEN,11)),U,18)
..S:PATNAME="" PATNAME="<none>"
..S:MAIDEN="" MAIDEN="<none>"
..S:CURCOM="" CURCOM="<none>"
..S:MAIDEN="" MAIDEN="<none>"
..;I $Y>(IOSL-1),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=$D(DUOUT) Q:ESCAPE D HDR(CRITERIA)
..I $D(IO("S")),($Y>(IOSL-1)),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=$D(DUOUT) Q:ESCAPE D HDR(CRITERIA) ;IHS/SD/IHS 2/17/2006 IM19904 FIX SUBMITTED BY MICHAEL TAYLOR
..I $Y>(IOSL-1),(IOST'[("C-")) D HDR(CRITERIA)
..;W:LN1=1 !!,"COMPARISON STRING=",FUNNYSUB PROGRAMMER ONLY
..W !,$E(PATNAME,1,25),$S(DECEASE:"#",1:""),?26,PATDOB,?38,$E(MAIDEN,1,15),?54,$E(CURCOM,1,15)
..S HRNFAC=0
..F LN2=1:1 S HRNFAC=$O(^AUPNPAT(PATIEN,41,HRNFAC)) Q:+HRNFAC=0 D
...Q:'$$ACTFAC(HRNFAC)
...S PSEUDO=$P($G(^AUTTLOC(HRNFAC,1)),U,2)
...S INACTIVE=$S((U_"I"_U)[(U_$P($G(^AUPNPAT(PATIEN,41,HRNFAC,0)),U,5)_U):"*",1:"")
...I 'INCACTDE Q:INACTIVE
...S HRN=$P($G(^AUPNPAT(PATIEN,41,HRNFAC,0)),U,2)
...W:LN2'=1 !
...W ?69,PSEUDO,?73,HRN_INACTIVE
;I IOST[("C-") W ! K DIR S DIR(0)="E" D ^DIR
I $D(IO("S")),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR ;IHS/SD/IHS 2/17/2006 IM19904 FIX SUBMITTED BY MICHAEL TAYLOR
Q
ACTFAC(FAC) ;EP - IS THE FACILITY ACTIVE?
S INACTDT=$P($G(^AUTTLOC(FAC,0)),U,21)
Q:INACTDT="" 1
I INACTDT>DT Q 1
Q 0
EXIT ;CLEANUP VARS
K EFFDATE,EMPLECNT,COUNT,EMPLEE,EMPLEENM,EMPLEREC,EMPLRBEG,EMPLRCNT,EMPLREND
K EMPLRNM,EMPLRREC,EMPREC
Q
SHOWCRIT(CRITERIA) ;EP - DISPLAY CRITERIA SELECTED
S CRITSTR=""
W !!,"You have selected "
F PIECE=1:1 S SEL=$P(CRITERIA,U,PIECE) Q:SEL="" D
.I PIECE'=1 W " and " S CRITSTR=CRITSTR_" and "
.W "#"_$P($T(CRITTXT+SEL),";;",2)
.S CRITSTR=CRITSTR_"#"_$P($T(CRITTXT+SEL),";;",2)
Q
HDR(CRITERIA) ;EP - MAIN HEADER
S PAGE=PAGE+1
W @IOF
W !,RPTREQ,?69,"page ",PAGE
W !
D CENTER^AGUTILS("INDIAN HEALTH HOSPITAL") ;AG*7.1*9 - Fixed misspelled HEALTH
W !
D CENTER^AGUTILS("POTENTIAL DUPLICATE PATIENT FILES REPORT")
W !
D WRAP^AGUTILS("CHECKING AGAINST "_CRITSTR,20,"WC50")
W !
D CENTER^AGUTILS("UCI: "_UCI)
W !
D CENTER^AGUTILS("('*' = INACTIVE), ('#' = DECEASED)")
W !!
D CENTER^AGUTILS("as of "_RPTDATE)
W !!
W "PATIENT NAME",?26,"BIRTH DATE",?38,"MOTHERS MAIDEN",?54,"CUR. COMMUNITY",?69,"LOC",?73,"HRN"
W !,"============",?26,"==========",?38,"==============",?54,"==============",?69,"===",?73,"======"
Q
QUE ;EP
K IO("Q")
S ZTRTN="MAIN^AGRPTPDP(CRITERIA)",ZTDESC="LISTING OF POTENTIAL DUPLICATE PATIENTS"
S ZTSAVE("CRITERIA")=""
S ZTSAVE("ALLLOC")=""
S ZTSAVE("INCACTDE")=""
S ZTSAVE("ROUTINE")=""
S ZTSAVE("RPTREQ")=""
S ZTSAVE("CRITSTR")=""
S ZTSAVE("UCI")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED AS TASK # "_ZTSK_" !",!
Q
CRITTXT ;;1:NAME^2:DOB^3:SSN^4:COM^5:MAIDEN
;;1-Last Name and First initial of Patient
;;2-Patient Date of Birth
;;3-Social Security Number
;;4-Current Community
;;5-Mother's Maiden Name
;;*END*
AGRPTPDP ;IHS/SD/TPF - POTENTIAL DUPLICATE PATIENT REPORT
+1 ;;7.1;PATIENT REGISTRATION;**1,2,9**;AUG 25, 2005
+2 ;
+3 ;REPORT OF POTENTIAL DUPLICATE PATIENTS BASED ON 5 CRITERIA
+4 ;
EN ;EP
+1 WRITE @IOF
+2 ;REPORT REQUESTED BY
SET RPTREQ=$PIECE($GET(^VA(200,DUZ,0)),U)
+3 XECUTE ^%ZOSF("UCI")
+4 SET UCI=$PIECE(Y,",")
+5 SET ROUTINE=$TEXT(+0)
+6 IF $GET(AGLINE("EQ"))=""
SET $PIECE(AGLINE("EQ"),"=",81)=""
+7 IF $GET(AGLINE("-"))=""
SET $PIECE(AGLINE("-"),"-",81)=""
+8 WRITE !,"This report is intended to help identify duplicate patient"
+9 WRITE !,"records in the Registration system. The system can check"
+10 WRITE !,"against the following fields:"
+11 WRITE !!
+12 WRITE !,"-Last Name and First initial of Patient"
+13 WRITE !,"-Patient Date of Birth"
+14 WRITE !,"-Social Security Number"
+15 WRITE !,"-Current Community"
+16 WRITE !,"-Mother's Maiden Name"
+17 WRITE !!
+18 WRITE !,"Choose at least two factors that you wish to check against for potential"
+19 WRITE !,"duplicates. The system will also prompt to check over active"
+20 WRITE !,"locations and inactive/deceased patients."
+21 WRITE !
+22 KILL DIR
+23 SET DIR(0)="E"
+24 DO ^DIR
ASKCRIT ;EP - ASK FOR CRITERIA
+1 WRITE @IOF
+2 WRITE !!
+3 WRITE !,"Please choose at least two criteria in which you want this report to run:"
+4 SET CRITERIA=""
ASKAGAIN ;EP
+1 KILL DIR,DTOUT,DUOUT,DIROUT,DIRUT
+2 IF CRITERIA=""
SET DIR("A")="Please make a selection"
+3 IF '$TEST
SET DIR("A")="Please make another selection"
+4 IF CRITERIA=""
SET DIR(0)="SO^1:NAME;2:DOB;3:SSN;4:COM;5:MAIDEN;A:ALL"
SET DIR("B")="All"
+5 IF '$TEST
SET DIR(0)="SO^1:NAME;2:DOB;3:SSN;4:COM;5:MAIDEN"
+6 SET DIR("L",1)="1. Last Name and First initial of Patient"
+7 SET DIR("L",2)="2. Date of Birth"
+8 SET DIR("L",3)="3. Social Security Number"
+9 SET DIR("L",4)="4. Current Community"
+10 SET DIR("L",5)="5. Mother's Maiden Name"
+11 SET DIR("L",6)=""
+12 SET DIR("L")=""
+13 DO ^DIR
+14 IF $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT
+15 IF Y'=""
IF CRITERIA'=""
IF (CRITERIA[(Y_":"_Y(0)))
WRITE !,"CRITERIA ALREADY SELECTED"
GOTO ASKAGAIN
+16 IF Y=""
IF (CRITERIA="")!($LENGTH(CRITERIA,U)<2)
WRITE !,"NOT ENOUGH CRITERIA SELECTED!"
GOTO ASKAGAIN
+17 IF Y=""
IF ($LENGTH(CRITERIA,U)>1)
DO SELCRIT(CRITERIA)
GOTO ASKCRIT
+18 IF Y(0)="ALL"
SET CRITERIA=$PIECE($TEXT(CRITTXT),";;",2)
DO SELCRIT(CRITERIA)
GOTO ASKCRIT
+19 IF CRITERIA=""
SET CRITERIA=Y_":"_Y(0)
+20 IF '$TEST
SET CRITERIA=CRITERIA_U_Y_":"_Y(0)
+21 GOTO ASKAGAIN
SELCRIT(CRITERIA) ;EP
A1 DO SHOWCRIT(CRITERIA)
+1 WRITE !
+2 KILL DIR
+3 SET DIR("A")="Is this correct"
+4 SET DIR("B")="Yes"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 IF 'Y
QUIT
A2 ;ASK IF TO INCLUDE ALL ACTIVE LOCATIONS
DO ASKLOC
IF $DATA(DUOUT)
GOTO A1
A3 ;ASK IF TO INCLUDE INACTIVE AND DECEASED PATIENTS
DO ASKACTDE
IF $DATA(DUOUT)
GOTO A2
A4 ;ASK FOR DEVICE
DO ASKDEV
+1 IF POP
GOTO A3
+2 IF $GET(IO("Q"))
DO QUE
QUIT
+3 USE IO
+4 DO MAIN(CRITERIA)
+5 ;IF PRINTING TO A SLAVE PRINTER FREEZES UP, THE CAUSE IS THE 'CLOSE EXECUTE' IN
+6 ;THE 'TERMINAL TYPE' FILE IS NOT FILLED IN FOR THE 'SUBTYPE' OF THE SLAVE
+7 ;DEVICE CHOSEN.
+8 DO ^%ZISC
+9 QUIT
ASKDEV ;EP
+1 SET %ZIS="Q"
+2 DO ^%ZIS
+3 QUIT
ASKLOC ;EP
+1 SET ALLLOC=0
+2 KILL DIR
+3 SET DIR("A")="Do you wish to include across all active locations"
+4 SET DIR("B")="Yes"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 SET ALLLOC=+Y
+8 QUIT
ASKACTDE ;EP
+1 SET INCACTDE=0
+2 KILL DIR
+3 SET DIR("A")="Do you wish to include inactive or deceased patients"
+4 SET DIR("B")="No"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 SET INCACTDE=+Y
+8 QUIT
MAIN(CRITERIA) ;MAIN
+1 KILL ^XTMP(ROUTINE)
+2 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+3 SET RPTDATE=Y
+4 SET (LASTINI,DOB,SSN,COM,MAIDEN)=""
+5 SET PATIEN=0
+6 FOR
SET PATIEN=$ORDER(^AUPNPAT(PATIEN))
IF +PATIEN=0
QUIT
Begin DoDot:1
+7 SET DECEASE=$$CHKDEATH^AGEDERR(PATIEN)
+8 ;INCLUDE DECEASE AND INACTIVE IS NO QUIT
IF 'INCACTDE
IF DECEASE
QUIT
+9 IF CRITERIA[("NAME")
Begin DoDot:2
+10 SET NAME=$PIECE($GET(^DPT(PATIEN,0)),U)
+11 SET LASTNAME=$PIECE(NAME,",")
+12 SET FIRSTINI=$EXTRACT($PIECE(NAME,",",2))
+13 SET LASTINI=LASTNAME_" "_FIRSTINI
End DoDot:2
+14 IF CRITERIA[("DOB")
Begin DoDot:2
+15 SET DOB=$PIECE($GET(^DPT(PATIEN,0)),U,3)
End DoDot:2
+16 IF CRITERIA[("SSN")
Begin DoDot:2
+17 SET SSN=$PIECE($GET(^DPT(PATIEN,0)),U,9)
End DoDot:2
+18 IF CRITERIA[("COM")
Begin DoDot:2
+19 ;FREE TEXT - NOT A GOOD CRITERIA
SET COM=$PIECE($GET(^AUPNPAT(PATIEN,11)),U,18)
End DoDot:2
+20 IF CRITERIA[("MAIDEN")
Begin DoDot:2
+21 ;FREE TEXT - NOT A GOOD CRITERIA
SET MAIDEN=$PIECE($GET(^DPT(PATIEN,.24)),U,3)
End DoDot:2
+22 SET FUNNYSUB=LASTINI_U_DOB_U_SSN_U_COM_U_MAIDEN
+23 SET ^XTMP(ROUTINE,$JOB,FUNNYSUB,PATIEN)=""
+24 SET ^XTMP(ROUTINE,$JOB,FUNNYSUB)=$GET(^XTMP(ROUTINE,$JOB,FUNNYSUB))+1
End DoDot:1
+25 WRITE !,"DUPLICATE CHECK COMPLETE "
+26 DO REPORT(CRITERIA)
+27 QUIT
REPORT(CRITERIA) ;EP
+1 SET PAGE=0
+2 SET ESCAPE=0
+3 DO HDR(CRITERIA)
+4 SET FUNNYSUB=""
+5 FOR
SET FUNNYSUB=$ORDER(^XTMP(ROUTINE,$JOB,FUNNYSUB))
IF FUNNYSUB=""
QUIT
Begin DoDot:1
+6 SET PATIEN=""
+7 FOR LN1=1:1
SET PATIEN=$ORDER(^XTMP(ROUTINE,$JOB,FUNNYSUB,PATIEN))
IF PATIEN=""
QUIT
Begin DoDot:2
+8 IF $GET(^XTMP(ROUTINE,$JOB,FUNNYSUB))<2
QUIT
+9 SET PATNAME=$PIECE($GET(^DPT(PATIEN,0)),U)
+10 SET DECEASE=$$CHKDEATH^AGEDERR(PATIEN)
+11 SET PATDOB=$PIECE($GET(^DPT(PATIEN,0)),U,3)
+12 IF PATDOB'=""
SET Y=PATDOB
XECUTE ^DD("DD")
SET PATDOB=Y
+13 IF '$TEST
SET PATDOB="<none>"
+14 SET MAIDEN=$PIECE($GET(^DPT(PATIEN,.24)),U,3)
+15 SET CURCOM=$PIECE($GET(^AUPNPAT(PATIEN,11)),U,18)
+16 IF PATNAME=""
SET PATNAME="<none>"
+17 IF MAIDEN=""
SET MAIDEN="<none>"
+18 IF CURCOM=""
SET CURCOM="<none>"
+19 IF MAIDEN=""
SET MAIDEN="<none>"
+20 ;I $Y>(IOSL-1),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=$D(DUOUT) Q:ESCAPE D HDR(CRITERIA)
+21 ;IHS/SD/IHS 2/17/2006 IM19904 FIX SUBMITTED BY MICHAEL TAYLOR
IF $DATA(IO("S"))
IF ($Y>(IOSL-1))
IF (IOST[("C-"))
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
SET ESCAPE=$DATA(DUOUT)
IF ESCAPE
QUIT
DO HDR(CRITERIA)
+22 IF $Y>(IOSL-1)
IF (IOST'[("C-"))
DO HDR(CRITERIA)
+23 ;W:LN1=1 !!,"COMPARISON STRING=",FUNNYSUB PROGRAMMER ONLY
+24 WRITE !,$EXTRACT(PATNAME,1,25),$SELECT(DECEASE:"#",1:""),?26,PATDOB,?38,$EXTRACT(MAIDEN,1,15),?54,$EXTRACT(CURCOM,1,15)
+25 SET HRNFAC=0
+26 FOR LN2=1:1
SET HRNFAC=$ORDER(^AUPNPAT(PATIEN,41,HRNFAC))
IF +HRNFAC=0
QUIT
Begin DoDot:3
+27 IF '$$ACTFAC(HRNFAC)
QUIT
+28 SET PSEUDO=$PIECE($GET(^AUTTLOC(HRNFAC,1)),U,2)
+29 SET INACTIVE=$SELECT((U_"I"_U)[(U_$PIECE($GET(^AUPNPAT(PATIEN,41,HRNFAC,0)),U,5)_U):"*",1:"")
+30 IF 'INCACTDE
IF INACTIVE
QUIT
+31 SET HRN=$PIECE($GET(^AUPNPAT(PATIEN,41,HRNFAC,0)),U,2)
+32 IF LN2'=1
WRITE !
+33 WRITE ?69,PSEUDO,?73,HRN_INACTIVE
End DoDot:3
End DoDot:2
IF ESCAPE
QUIT
End DoDot:1
IF ESCAPE
QUIT
+34 ;I IOST[("C-") W ! K DIR S DIR(0)="E" D ^DIR
+35 ;IHS/SD/IHS 2/17/2006 IM19904 FIX SUBMITTED BY MICHAEL TAYLOR
IF $DATA(IO("S"))
IF (IOST[("C-"))
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
+36 QUIT
ACTFAC(FAC) ;EP - IS THE FACILITY ACTIVE?
+1 SET INACTDT=$PIECE($GET(^AUTTLOC(FAC,0)),U,21)
+2 IF INACTDT=""
QUIT 1
+3 IF INACTDT>DT
QUIT 1
+4 QUIT 0
EXIT ;CLEANUP VARS
+1 KILL EFFDATE,EMPLECNT,COUNT,EMPLEE,EMPLEENM,EMPLEREC,EMPLRBEG,EMPLRCNT,EMPLREND
+2 KILL EMPLRNM,EMPLRREC,EMPREC
+3 QUIT
SHOWCRIT(CRITERIA) ;EP - DISPLAY CRITERIA SELECTED
+1 SET CRITSTR=""
+2 WRITE !!,"You have selected "
+3 FOR PIECE=1:1
SET SEL=$PIECE(CRITERIA,U,PIECE)
IF SEL=""
QUIT
Begin DoDot:1
+4 IF PIECE'=1
WRITE " and "
SET CRITSTR=CRITSTR_" and "
+5 WRITE "#"_$PIECE($TEXT(CRITTXT+SEL),";;",2)
+6 SET CRITSTR=CRITSTR_"#"_$PIECE($TEXT(CRITTXT+SEL),";;",2)
End DoDot:1
+7 QUIT
HDR(CRITERIA) ;EP - MAIN HEADER
+1 SET PAGE=PAGE+1
+2 WRITE @IOF
+3 WRITE !,RPTREQ,?69,"page ",PAGE
+4 WRITE !
+5 ;AG*7.1*9 - Fixed misspelled HEALTH
DO CENTER^AGUTILS("INDIAN HEALTH HOSPITAL")
+6 WRITE !
+7 DO CENTER^AGUTILS("POTENTIAL DUPLICATE PATIENT FILES REPORT")
+8 WRITE !
+9 DO WRAP^AGUTILS("CHECKING AGAINST "_CRITSTR,20,"WC50")
+10 WRITE !
+11 DO CENTER^AGUTILS("UCI: "_UCI)
+12 WRITE !
+13 DO CENTER^AGUTILS("('*' = INACTIVE), ('#' = DECEASED)")
+14 WRITE !!
+15 DO CENTER^AGUTILS("as of "_RPTDATE)
+16 WRITE !!
+17 WRITE "PATIENT NAME",?26,"BIRTH DATE",?38,"MOTHERS MAIDEN",?54,"CUR. COMMUNITY",?69,"LOC",?73,"HRN"
+18 WRITE !,"============",?26,"==========",?38,"==============",?54,"==============",?69,"===",?73,"======"
+19 QUIT
QUE ;EP
+1 KILL IO("Q")
+2 SET ZTRTN="MAIN^AGRPTPDP(CRITERIA)"
SET ZTDESC="LISTING OF POTENTIAL DUPLICATE PATIENTS"
+3 SET ZTSAVE("CRITERIA")=""
+4 SET ZTSAVE("ALLLOC")=""
+5 SET ZTSAVE("INCACTDE")=""
+6 SET ZTSAVE("ROUTINE")=""
+7 SET ZTSAVE("RPTREQ")=""
+8 SET ZTSAVE("CRITSTR")=""
+9 SET ZTSAVE("UCI")=""
+10 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"REQUEST QUEUED AS TASK # "_ZTSK_" !",!
+11 QUIT
CRITTXT ;;1:NAME^2:DOB^3:SSN^4:COM^5:MAIDEN
+1 ;;1-Last Name and First initial of Patient
+2 ;;2-Patient Date of Birth
+3 ;;3-Social Security Number
+4 ;;4-Current Community
+5 ;;5-Mother's Maiden Name
+6 ;;*END*
