AGGRPTDP ; VNGT/HS/KDC - POTENTIAL DUPLICATE PATIENT REPORT
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
; Copied from AGRPTPDP
;
;REPORT OF POTENTIAL DUPLICATE PATIENTS BASED ON 5 CRITERIA
;
Q
;
EN(DATA,QNAM,QDOB,QSSN,QCOM,QM,QALL,QIN) ; EP -AGG POTENTIAL DUPLICATE PATIENT REPORT
;Description
; Generates AGG POTENTIAL DUPLICATE PATIENT REPORT
;
;Input
; QNAM - A flag inticating user's selection
; QDOB - A flag inticating user's selection
; QSSN - A flag inticating user's selection
; QCOM - A flag inticating user's selection
; QM - A flag inticating user's selection
; QALL - A flag inticating user's selection
; QIN - A flag inticating user's selection
;
;Output
; DATA - Name of global in which data is stored(^TMP("AGGRPTDP"))
;
NEW UID,X,AGGI,HSTEXT,HSPATH,HSFN,Y,IOSL,IOST,IOM,I,N
NEW CRITERIA,INCACTDE,ALLLOC,CRITSTRE,AGLINE,CURCOM,DECEASE
NEW FUNNYSUB,MAIDEN,PAGE,PATIEN,RPTDATE,RPTREQ,UCI,CNT,CRITSTR
;I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
I '$D(DT) D DT^DICRW
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("AGGRPTDP",UID))
K @DATA
S AGGI=0
D HDR
I $$TMPFL^AGGUL1("W",UID,"AGG"_$J) G DONE
;I $L($G(RPTCRT),U)'=7 S BMXSEC="Invalid search criteria." G DONE
S CRITERIA=""
S CNT=0
I $G(QNAM)="Y" S CRITERIA="1:NAME",CNT=CNT+1
I $G(QDOB)="Y" S CNT=CNT+1 S:CRITERIA]"" CRITERIA=CRITERIA_U_"2:DOB" S:CRITERIA="" CRITERIA="2:DOB"
I $G(QSSN)="Y" S CNT=CNT+1 S:CRITERIA]"" CRITERIA=CRITERIA_U_"3:SSN" S:CRITERIA="" CRITERIA="3:SSN"
I $G(QCOM)="Y" S CNT=CNT+1 S:CRITERIA]"" CRITERIA=CRITERIA_U_"4:COM" S:CRITERIA="" CRITERIA="4:COM"
I $G(QM)="Y" S CNT=CNT+1 S:CRITERIA]"" CRITERIA=CRITERIA_U_"5:MAIDEN" S:CRITERIA="" CRITERIA="5:MAIDEN"
I CNT<2 D G DONE
. S @DATA@(AGGI)="T01024REPORT_TEXT"_$C(30)
. S AGGI=AGGI+1
. S @DATA@(AGGI)="NOT ENOUGH CRITERIA SELECTED!"_$C(30)
S (ALLLOC,INCACTDE)=0
I $G(QALL)="Y" S ALLLOC=1
I $G(QIN)="Y" S INCACTDE=1
U IO
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)=""
D SHOWCRIT(CRITERIA)
D MAIN(CRITERIA)
D BGL
;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
K ROUTINE
Q
MAIN(CRITERIA) ;MAIN
NEW FIRSTINI,LASTINI,LASTNAME,SSN,NAME,DOB,COM,%
K ^TMP("AGG",$J)
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 ^TMP("AGG",$J,FUNNYSUB,PATIEN)=""
.S ^TMP("AGG",$J,FUNNYSUB)=$G(^TMP("AGG",$J,FUNNYSUB))+1
D REPORT(CRITERIA)
Q
REPORT(CRITERIA) ;EP
NEW ESCAPE,HRNFAC,INACTIVE,LN1,LN2,PATDOB,PATNAME,PSEUDO,HRN
S PAGE=0
S ESCAPE=0
D RHDR(CRITERIA)
S FUNNYSUB=""
F S FUNNYSUB=$O(^TMP("AGG",$J,FUNNYSUB)) Q:FUNNYSUB="" D Q:ESCAPE
.S PATIEN=""
.F LN1=1:1 S PATIEN=$O(^TMP("AGG",$J,FUNNYSUB,PATIEN)) Q:PATIEN="" D Q:ESCAPE
..Q:$G(^TMP("AGG",$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 RHDR(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 RHDR(CRITERIA) ;IHS/SD/IHS 2/17/2006 IM19904 FIX SUBMITTED BY MICHAEL TAYLOR
..;I $Y>(IOSL-1),(IOST'[("C-")) D RHDR(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?
NEW INACTDT
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
NEW PIECE,SEL
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
RHDR(CRITERIA) ;EP - MAIN HEADER
S PAGE=PAGE+1,IOM=80
W @IOF
W !,RPTREQ,?69,"page ",PAGE
W !
D CENTER^AGUTILS("INDIAN HEALTH HOSPITAL")
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*
;;
BGL U IO W !,$C(9)
;
;
I $$TMPFL^AGGUL1("C") G DONE
I $$TMPFL^AGGUL1("R",UID,"AGG"_$J) G DONE
;
F U IO R HSTEXT:.1 Q:HSTEXT[$C(9) D
. S HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
. I HSTEXT="" S HSTEXT=" "
. S AGGI=AGGI+1,@DATA@(AGGI)=HSTEXT_$C(13)_$C(10)_$C(30)
S AGGI=AGGI+1,@DATA@(AGGI)=$C(30)
;
I $$TMPFL^AGGUL1("C") G DONE
I $$TMPFL^AGGUL1("D",UID,"AGG"_$J) G DONE
;
DONE ;
;
S AGGI=AGGI+1,@DATA@(AGGI)=$C(31)
Q
;
HDR ;
S @DATA@(AGGI)="T01024REPORT_TEXT"_$C(30)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S BMXSEC="Recording that an error occurred at "_ERRDTM
I $D(AGGI),$D(DATA) S AGGI=AGGI+1,@DATA@(AGGI)=$C(31)
I $$TMPFL^AGGUL1("C")
Q
AGGRPTDP ; VNGT/HS/KDC - POTENTIAL DUPLICATE PATIENT REPORT
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ; Copied from AGRPTPDP
+4 ;
+5 ;REPORT OF POTENTIAL DUPLICATE PATIENTS BASED ON 5 CRITERIA
+6 ;
+7 QUIT
+8 ;
EN(DATA,QNAM,QDOB,QSSN,QCOM,QM,QALL,QIN) ; EP -AGG POTENTIAL DUPLICATE PATIENT REPORT
+1 ;Description
+2 ; Generates AGG POTENTIAL DUPLICATE PATIENT REPORT
+3 ;
+4 ;Input
+5 ; QNAM - A flag inticating user's selection
+6 ; QDOB - A flag inticating user's selection
+7 ; QSSN - A flag inticating user's selection
+8 ; QCOM - A flag inticating user's selection
+9 ; QM - A flag inticating user's selection
+10 ; QALL - A flag inticating user's selection
+11 ; QIN - A flag inticating user's selection
+12 ;
+13 ;Output
+14 ; DATA - Name of global in which data is stored(^TMP("AGGRPTDP"))
+15 ;
+16 NEW UID,X,AGGI,HSTEXT,HSPATH,HSFN,Y,IOSL,IOST,IOM,I,N
+17 NEW CRITERIA,INCACTDE,ALLLOC,CRITSTRE,AGLINE,CURCOM,DECEASE
+18 NEW FUNNYSUB,MAIDEN,PAGE,PATIEN,RPTDATE,RPTREQ,UCI,CNT,CRITSTR
+19 ;I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
+20 IF '$DATA(DT)
DO DT^DICRW
+21 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+22 SET DATA=$NAME(^TMP("AGGRPTDP",UID))
+23 KILL @DATA
+24 SET AGGI=0
+25 DO HDR
+26 IF $$TMPFL^AGGUL1("W",UID,"AGG"_$JOB)
GOTO DONE
+27 ;I $L($G(RPTCRT),U)'=7 S BMXSEC="Invalid search criteria." G DONE
+28 SET CRITERIA=""
+29 SET CNT=0
+30 IF $GET(QNAM)="Y"
SET CRITERIA="1:NAME"
SET CNT=CNT+1
+31 IF $GET(QDOB)="Y"
SET CNT=CNT+1
IF CRITERIA]""
SET CRITERIA=CRITERIA_U_"2:DOB"
IF CRITERIA=""
SET CRITERIA="2:DOB"
+32 IF $GET(QSSN)="Y"
SET CNT=CNT+1
IF CRITERIA]""
SET CRITERIA=CRITERIA_U_"3:SSN"
IF CRITERIA=""
SET CRITERIA="3:SSN"
+33 IF $GET(QCOM)="Y"
SET CNT=CNT+1
IF CRITERIA]""
SET CRITERIA=CRITERIA_U_"4:COM"
IF CRITERIA=""
SET CRITERIA="4:COM"
+34 IF $GET(QM)="Y"
SET CNT=CNT+1
IF CRITERIA]""
SET CRITERIA=CRITERIA_U_"5:MAIDEN"
IF CRITERIA=""
SET CRITERIA="5:MAIDEN"
+35 IF CNT<2
Begin DoDot:1
+36 SET @DATA@(AGGI)="T01024REPORT_TEXT"_$CHAR(30)
+37 SET AGGI=AGGI+1
+38 SET @DATA@(AGGI)="NOT ENOUGH CRITERIA SELECTED!"_$CHAR(30)
End DoDot:1
GOTO DONE
+39 SET (ALLLOC,INCACTDE)=0
+40 IF $GET(QALL)="Y"
SET ALLLOC=1
+41 IF $GET(QIN)="Y"
SET INCACTDE=1
+42 USE IO
+43 WRITE @IOF
+44 ;REPORT REQUESTED BY
SET RPTREQ=$PIECE($GET(^VA(200,DUZ,0)),U)
+45 XECUTE ^%ZOSF("UCI")
+46 SET UCI=$PIECE(Y,",")
+47 SET ROUTINE=$TEXT(+0)
+48 IF $GET(AGLINE("EQ"))=""
SET $PIECE(AGLINE("EQ"),"=",81)=""
+49 IF $GET(AGLINE("-"))=""
SET $PIECE(AGLINE("-"),"-",81)=""
+50 DO SHOWCRIT(CRITERIA)
+51 DO MAIN(CRITERIA)
+52 DO BGL
+53 ;IF PRINTING TO A SLAVE PRINTER FREEZES UP, THE CAUSE IS THE 'CLOSE EXECUTE' IN
+54 ;THE 'TERMINAL TYPE' FILE IS NOT FILLED IN FOR THE 'SUBTYPE' OF THE SLAVE
+55 ;DEVICE CHOSEN.
+56 ;D ^%ZISC
+57 KILL ROUTINE
+58 QUIT
MAIN(CRITERIA) ;MAIN
+1 NEW FIRSTINI,LASTINI,LASTNAME,SSN,NAME,DOB,COM,%
+2 KILL ^TMP("AGG",$JOB)
+3 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+4 SET RPTDATE=Y
+5 SET (LASTINI,DOB,SSN,COM,MAIDEN)=""
+6 SET PATIEN=0
+7 FOR
SET PATIEN=$ORDER(^AUPNPAT(PATIEN))
IF +PATIEN=0
QUIT
Begin DoDot:1
+8 SET DECEASE=$$CHKDEATH^AGEDERR(PATIEN)
+9 ;INCLUDE DECEASE AND INACTIVE IS NO QUIT
IF 'INCACTDE
IF DECEASE
QUIT
+10 IF CRITERIA[("NAME")
Begin DoDot:2
+11 SET NAME=$PIECE($GET(^DPT(PATIEN,0)),U)
+12 SET LASTNAME=$PIECE(NAME,",")
+13 SET FIRSTINI=$EXTRACT($PIECE(NAME,",",2))
+14 SET LASTINI=LASTNAME_" "_FIRSTINI
End DoDot:2
+15 IF CRITERIA[("DOB")
Begin DoDot:2
+16 SET DOB=$PIECE($GET(^DPT(PATIEN,0)),U,3)
End DoDot:2
+17 IF CRITERIA[("SSN")
Begin DoDot:2
+18 SET SSN=$PIECE($GET(^DPT(PATIEN,0)),U,9)
End DoDot:2
+19 IF CRITERIA[("COM")
Begin DoDot:2
+20 ;FREE TEXT - NOT A GOOD CRITERIA
SET COM=$PIECE($GET(^AUPNPAT(PATIEN,11)),U,18)
End DoDot:2
+21 IF CRITERIA[("MAIDEN")
Begin DoDot:2
+22 ;FREE TEXT - NOT A GOOD CRITERIA
SET MAIDEN=$PIECE($GET(^DPT(PATIEN,.24)),U,3)
End DoDot:2
+23 SET FUNNYSUB=LASTINI_U_DOB_U_SSN_U_COM_U_MAIDEN
+24 SET ^TMP("AGG",$JOB,FUNNYSUB,PATIEN)=""
+25 SET ^TMP("AGG",$JOB,FUNNYSUB)=$GET(^TMP("AGG",$JOB,FUNNYSUB))+1
End DoDot:1
+26 DO REPORT(CRITERIA)
+27 QUIT
REPORT(CRITERIA) ;EP
+1 NEW ESCAPE,HRNFAC,INACTIVE,LN1,LN2,PATDOB,PATNAME,PSEUDO,HRN
+2 SET PAGE=0
+3 SET ESCAPE=0
+4 DO RHDR(CRITERIA)
+5 SET FUNNYSUB=""
+6 FOR
SET FUNNYSUB=$ORDER(^TMP("AGG",$JOB,FUNNYSUB))
IF FUNNYSUB=""
QUIT
Begin DoDot:1
+7 SET PATIEN=""
+8 FOR LN1=1:1
SET PATIEN=$ORDER(^TMP("AGG",$JOB,FUNNYSUB,PATIEN))
IF PATIEN=""
QUIT
Begin DoDot:2
+9 IF $GET(^TMP("AGG",$JOB,FUNNYSUB))<2
QUIT
+10 SET PATNAME=$PIECE($GET(^DPT(PATIEN,0)),U)
+11 SET DECEASE=$$CHKDEATH^AGEDERR(PATIEN)
+12 SET PATDOB=$PIECE($GET(^DPT(PATIEN,0)),U,3)
+13 IF PATDOB'=""
SET Y=PATDOB
XECUTE ^DD("DD")
SET PATDOB=Y
+14 IF '$TEST
SET PATDOB="<none>"
+15 SET MAIDEN=$PIECE($GET(^DPT(PATIEN,.24)),U,3)
+16 SET CURCOM=$PIECE($GET(^AUPNPAT(PATIEN,11)),U,18)
+17 IF PATNAME=""
SET PATNAME="<none>"
+18 IF MAIDEN=""
SET MAIDEN="<none>"
+19 IF CURCOM=""
SET CURCOM="<none>"
+20 IF MAIDEN=""
SET MAIDEN="<none>"
+21 ;I $Y>(IOSL-1),(IOST[("C-")) W ! K DIR S DIR(0)="E" D ^DIR S ESCAPE=$D(DUOUT) Q:ESCAPE D RHDR(CRITERIA)
+22 ;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 RHDR(CRITERIA) ;IHS/SD/IHS 2/17/2006 IM19904 FIX SUBMITTED BY MICHAEL TAYLOR
+23 ;I $Y>(IOSL-1),(IOST'[("C-")) D RHDR(CRITERIA)
+24 ;W:LN1=1 !!,"COMPARISON STRING=",FUNNYSUB PROGRAMMER ONLY
+25 WRITE !,$EXTRACT(PATNAME,1,25),$SELECT(DECEASE:"#",1:""),?26,PATDOB,?38,$EXTRACT(MAIDEN,1,15),?54,$EXTRACT(CURCOM,1,15)
+26 SET HRNFAC=0
+27 FOR LN2=1:1
SET HRNFAC=$ORDER(^AUPNPAT(PATIEN,41,HRNFAC))
IF +HRNFAC=0
QUIT
Begin DoDot:3
+28 IF '$$ACTFAC(HRNFAC)
QUIT
+29 SET PSEUDO=$PIECE($GET(^AUTTLOC(HRNFAC,1)),U,2)
+30 SET INACTIVE=$SELECT((U_"I"_U)[(U_$PIECE($GET(^AUPNPAT(PATIEN,41,HRNFAC,0)),U,5)_U):"*",1:"")
+31 IF 'INCACTDE
IF INACTIVE
QUIT
+32 SET HRN=$PIECE($GET(^AUPNPAT(PATIEN,41,HRNFAC,0)),U,2)
+33 IF LN2'=1
WRITE !
+34 WRITE ?69,PSEUDO,?73,HRN_INACTIVE
End DoDot:3
End DoDot:2
IF ESCAPE
QUIT
End DoDot:1
IF ESCAPE
QUIT
+35 ;I IOST[("C-") W ! K DIR S DIR(0)="E" D ^DIR
+36 ;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
+37 QUIT
ACTFAC(FAC) ;EP - IS THE FACILITY ACTIVE?
+1 NEW INACTDT
+2 SET INACTDT=$PIECE($GET(^AUTTLOC(FAC,0)),U,21)
+3 IF INACTDT=""
QUIT 1
+4 IF INACTDT>DT
QUIT 1
+5 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 NEW PIECE,SEL
+2 SET CRITSTR=""
+3 ;W !!,"You have selected "
+4 FOR PIECE=1:1
SET SEL=$PIECE(CRITERIA,U,PIECE)
IF SEL=""
QUIT
Begin DoDot:1
+5 ;I PIECE'=1 W " and " S CRITSTR=CRITSTR_" and "
+6 ;W "#"_$P($T(CRITTXT+SEL),";;",2)
+7 SET CRITSTR=CRITSTR_"#"_$PIECE($TEXT(CRITTXT+SEL),";;",2)
End DoDot:1
+8 QUIT
RHDR(CRITERIA) ;EP - MAIN HEADER
+1 SET PAGE=PAGE+1
SET IOM=80
+2 WRITE @IOF
+3 WRITE !,RPTREQ,?69,"page ",PAGE
+4 WRITE !
+5 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 ;K IO("Q")
+2 ;S ZTRTN="MAIN^AGRPTPDP(CRITERIA)",ZTDESC="LISTING OF POTENTIAL DUPLICATE PATIENTS"
+3 ;S ZTSAVE("CRITERIA")=""
+4 ;S ZTSAVE("ALLLOC")=""
+5 ;S ZTSAVE("INCACTDE")=""
+6 ;S ZTSAVE("ROUTINE")=""
+7 ;S ZTSAVE("RPTREQ")=""
+8 ;S ZTSAVE("CRITSTR")=""
+9 ;S ZTSAVE("UCI")=""
+10 ;D ^%ZTLOAD W:$D(ZTSK) !,"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*
+7 ;;
BGL USE IO
WRITE !,$CHAR(9)
+1 ;
+2 ;
+3 IF $$TMPFL^AGGUL1("C")
GOTO DONE
+4 IF $$TMPFL^AGGUL1("R",UID,"AGG"_$JOB)
GOTO DONE
+5 ;
+6 FOR
USE IO
READ HSTEXT:.1
IF HSTEXT[$CHAR(9)
QUIT
Begin DoDot:1
+7 SET HSTEXT=$$STRIP^XLFSTR(HSTEXT,"^")
+8 IF HSTEXT=""
SET HSTEXT=" "
+9 SET AGGI=AGGI+1
SET @DATA@(AGGI)=HSTEXT_$CHAR(13)_$CHAR(10)_$CHAR(30)
End DoDot:1
+10 SET AGGI=AGGI+1
SET @DATA@(AGGI)=$CHAR(30)
+11 ;
+12 IF $$TMPFL^AGGUL1("C")
GOTO DONE
+13 IF $$TMPFL^AGGUL1("D",UID,"AGG"_$JOB)
GOTO DONE
+14 ;
DONE ;
+1 ;
+2 SET AGGI=AGGI+1
SET @DATA@(AGGI)=$CHAR(31)
+3 QUIT
+4 ;
HDR ;
+1 SET @DATA@(AGGI)="T01024REPORT_TEXT"_$CHAR(30)
+2 QUIT
+3 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET BMXSEC="Recording that an error occurred at "_ERRDTM
+5 IF $DATA(AGGI)
IF $DATA(DATA)
SET AGGI=AGGI+1
SET @DATA@(AGGI)=$CHAR(31)
+6 IF $$TMPFL^AGGUL1("C")
+7 QUIT
