AGRPTPDP.m

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*