AGEDNAME ;IHS/ASDST/GTH - NAME STANDARDIZATION REPORT ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
TXT ;
;;This report is intended to help in Patient identification by searching
;;through all the various ways that PtReg collects "NAME"s of patients,
;;and checking them for conformance to standard formats for names used
;;by the I/T/Us:
;; 1...Use from 3 to 30 letters
;; 2...a COMMA MUST FOLLOW THE LAST NAME
;; 3...If "JR" or "II", etc, is included, follow the form
;; SMITH,JOHN MARK,JR.
;; 4...NO SPACES after commas.
;;The following name fields are checked:
;; PATIENT NAME, EMERGENCY CONTACT, FATHER'S NAME, MOTHER'S MAIDEN
;; NAME, OTHER NAME (ALIASES), NAME OF INSURED (MCD), NAME OF POLICY
;; HOLDER, NAME OF INSURED (PVT), and NEXT OF KIN.
;;
;;Deleted or Merge'd patients are not checked.
;;###
TXT1 ;
;;In the following report, the value of FIELD indicates where to go in
;;the PtReg application to correct the VALUE. Here's the fields that
;;are checked, and corresponding locations in RPMS PtReg, by page number
;;and field number that are used on the "Patient Registration" option
;;or the pages on the "EDIT a patient's file" option:
;;
;; Field Option Page# Field#
;; -------------------- --------------------- --- ---
;; PATIENT NAME Patient Registration (NAM)
;; EMERGENCY CONTACT EDIT a patient's file 3 1
;; FATHER'S NAME EDIT a patient's file 3 8
;; MOTHER'S MAIDEN NAME EDIT a patient's file 3 11
;; OTHER NAME (ALIASES) EDIT a patient's file 8 4
;; NAME OF INSURED (MCD) EDIT a patient's file 5 "E"
;; NAME OF POLICY HOLDER EDIT a patient's file 7a "E"
;; NAME OF INSURED (PVT) EDIT a patient's file 7a "E"
;; NEXT OF KIN EDIT a patient's file 10 1
;;
;; -- Here is the report:
;;ASUFAC HRN FIELD VALUE
;;====== ====== ===================== =============================
;;###
; --------------------------------------------------------
QUE ;EP - From Option
D HELP^XBHELP("TXT","AGEDNAME")
Q:'$$DIR^XBDIR("YO","Proceed","N","","Do you want to proceed with the report to check format of names (Y/N)")
S XBRP="START^AGEDNAME",ZTIO=""
D ^XBDBQUE,HOME^%ZIS
I $D(ZTSK) W !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!
Q
START ;EP - From Taskman
N AG,AGFAC,AGHRN,DFN,AGDONE,AGP3,AGSITE
K ^TMP("AGEDNAME",$J)
F %=1:1 D OUT($P($T(TXT+%),";",3)) Q:$P($T(TXT+%+1),";",3)="###"
F %=1:1 D OUT($P($T(TXT1+%),";",3)) Q:$P($T(TXT1+%+1),";",3)="###"
S DFN=0,AGP3=$P($G(^AUPNPAT(0)),U,3)
F S DFN=$O(^AUPNPAT(DFN)) Q:'DFN D I '(DFN#1000),'$D(ZTQUEUED) W !,"On IEN ",DFN," of ",AGP3," in ^AUPNPAT(..."
. Q:'$D(^DPT(DFN)) Q:$P(^(DFN,0),U,19) ;merged pt
. S (AGDONE,AGSITE)=0
. F S AGSITE=$O(^AUPNPAT(DFN,41,AGSITE)) Q:'AGSITE D Q:AGDONE
.. I $L($P($G(^AUPNPAT(DFN,41,AGSITE,0)),U,5)) Q:"DM"[$P(^(0),U,5) ;deleted or merged patient
.. S AGFAC=$P($G(^AUTTLOC(DUZ(2),0)),U,10),AGHRN="??????"
.. I $L($P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)) S AGHRN=$P(^(0),U,2)
.. E I $L($P($G(^AUPNPAT(DFN,41,AGSITE,0)),U,2)) S AGHRN=$P(^(0),U,2),AGFAC=$P($G(^AUTTLOC(AGSITE,0)),U,10)
.. D CHK("PATIENT NAME : ",$P($G(^DPT(DFN,0)),U))
.. D CHK("EMERGENCY CONTACT : ",$P($G(^DPT(DFN,.33)),U))
.. D CHK("FATHER'S NAME : ",$P($G(^DPT(DFN,.24)),U))
.. D CHK("MOTHER'S MAIDEN NAME : ",$P($G(^DPT(DFN,.24)),U,3))
.. D CHK("NEXT OF KIN : ",$P($G(^DPT(DFN,.21)),U))
.. D MCD
.. S AG=0
.. F S AG=$O(^DPT(DFN,.01,AG)) Q:'AG D CHK("OTHER NAME (ALIASES) : ",$P($G(^DPT(DFN,.01,AG,0)),U))
.. S AG=0
.. F S AG=$O(^AUPNPRVT(DFN,11,AG)) Q:'AG D
... D CHK("NAME OF INSURED (PVT) : ",$P($G(^AUPNPRVT(DFN,11,AG,0)),U,4))
... D NPH($P($G(^AUPNPRVT(DFN,11,AG,0)),U,8))
...Q
.. S AGDONE=1 ;pt is done, one and only one time
..Q
.Q
NEW XMSUB,XMDUZ,XMTEXT,XMY
S XMSUB=$P($P($T(+1),";",2)," ",3,99),XMDUZ=$S($G(DUZ):DUZ,1:.5),XMTEXT="^TMP(""AGEDNAME"",$J,",XMY(1)="",XMY(DUZ)=""
F %="XUPROGMODE","AGZMENU","AGZMGR","ABMDZ TABLE MAINTENANCE","ABMDZ ELIGIBILITY EDIT","APCCZMGR" D SINGLE(%)
D ^XMD
KILL ^TMP("AGEDNAME",$J)
D EN^XBVK("AG")
I $D(ZTQUEUED) S ZTREQ="@" Q
W !!,"The results are in your MailMan 'IN' basket.",!
Q
MCD ;
NEW D,N,S
S S=0
F S S=$O(^AUPNMCD("AB",DFN,S)) Q:'S S N=0 D
. F S N=$O(^AUPNMCD("AB",DFN,S,N)) Q:'N S D=0 D
.. F S D=$O(^AUPNMCD("AB",DFN,S,N,D)) Q:'D D
... D CHK("NAME OF INSURED (MCD) : ",$P($G(^AUPNMCD(D,0)),U,5))
... D NPH($P($G(^AUPNMCD(D,0)),U,9))
...Q
..Q
.Q
Q
NPH(I) ;
Q:'I
D CHK("NAME OF POLICY HOLDER : ",$P($G(^AUPN3PPH(I,0)),U))
Q
CHK(F,X) ;
Q:((X="")!(X="SAME"))
NEW AG
S AG=X
D NAME^AUPNPED
Q:$D(X)
D RSLT(F_U_AG)
Q
RSLT(%) S %=$J(AGFAC,6)_$J(AGHRN,8)_$J($P(%,U,1),30)_"'"_$P(%,U,2)_"'"
RSLT1 S ^(0)=$G(^TMP("AGEDNAME",$J,0))+1,^(^(0))=% W:'$D(ZTQUEUED) !,%
Q
OUT(%) D RSLT1 Q
SINGLE(K) ;Get holders of a single key K.
NEW Y
S Y=0
Q:'$D(^XUSEC(K))
F S Y=$O(^XUSEC(K,Y)) Q:'Y S XMY(Y)=""
Q
AGEDNAME ;IHS/ASDST/GTH - NAME STANDARDIZATION REPORT ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
TXT ;
+1 ;;This report is intended to help in Patient identification by searching
+2 ;;through all the various ways that PtReg collects "NAME"s of patients,
+3 ;;and checking them for conformance to standard formats for names used
+4 ;;by the I/T/Us:
+5 ;; 1...Use from 3 to 30 letters
+6 ;; 2...a COMMA MUST FOLLOW THE LAST NAME
+7 ;; 3...If "JR" or "II", etc, is included, follow the form
+8 ;; SMITH,JOHN MARK,JR.
+9 ;; 4...NO SPACES after commas.
+10 ;;The following name fields are checked:
+11 ;; PATIENT NAME, EMERGENCY CONTACT, FATHER'S NAME, MOTHER'S MAIDEN
+12 ;; NAME, OTHER NAME (ALIASES), NAME OF INSURED (MCD), NAME OF POLICY
+13 ;; HOLDER, NAME OF INSURED (PVT), and NEXT OF KIN.
+14 ;;
+15 ;;Deleted or Merge'd patients are not checked.
+16 ;;###
TXT1 ;
+1 ;;In the following report, the value of FIELD indicates where to go in
+2 ;;the PtReg application to correct the VALUE. Here's the fields that
+3 ;;are checked, and corresponding locations in RPMS PtReg, by page number
+4 ;;and field number that are used on the "Patient Registration" option
+5 ;;or the pages on the "EDIT a patient's file" option:
+6 ;;
+7 ;; Field Option Page# Field#
+8 ;; -------------------- --------------------- --- ---
+9 ;; PATIENT NAME Patient Registration (NAM)
+10 ;; EMERGENCY CONTACT EDIT a patient's file 3 1
+11 ;; FATHER'S NAME EDIT a patient's file 3 8
+12 ;; MOTHER'S MAIDEN NAME EDIT a patient's file 3 11
+13 ;; OTHER NAME (ALIASES) EDIT a patient's file 8 4
+14 ;; NAME OF INSURED (MCD) EDIT a patient's file 5 "E"
+15 ;; NAME OF POLICY HOLDER EDIT a patient's file 7a "E"
+16 ;; NAME OF INSURED (PVT) EDIT a patient's file 7a "E"
+17 ;; NEXT OF KIN EDIT a patient's file 10 1
+18 ;;
+19 ;; -- Here is the report:
+20 ;;ASUFAC HRN FIELD VALUE
+21 ;;====== ====== ===================== =============================
+22 ;;###
+23 ; --------------------------------------------------------
QUE ;EP - From Option
+1 DO HELP^XBHELP("TXT","AGEDNAME")
+2 IF '$$DIR^XBDIR("YO","Proceed","N","","Do you want to proceed with the report to check format of names (Y/N)")
QUIT
+3 SET XBRP="START^AGEDNAME"
SET ZTIO=""
+4 DO ^XBDBQUE
DO HOME^%ZIS
+5 IF $DATA(ZTSK)
WRITE !!,"QUEUED TO TASK ",ZTSK,!!,"A mail message with the results will be sent to your MailMan 'IN' basket.",!
+6 QUIT
START ;EP - From Taskman
+1 NEW AG,AGFAC,AGHRN,DFN,AGDONE,AGP3,AGSITE
+2 KILL ^TMP("AGEDNAME",$JOB)
+3 FOR %=1:1
DO OUT($PIECE($TEXT(TXT+%),";",3))
IF $PIECE($TEXT(TXT+%+1),";",3)="###"
QUIT
+4 FOR %=1:1
DO OUT($PIECE($TEXT(TXT1+%),";",3))
IF $PIECE($TEXT(TXT1+%+1),";",3)="###"
QUIT
+5 SET DFN=0
SET AGP3=$PIECE($GET(^AUPNPAT(0)),U,3)
+6 FOR
SET DFN=$ORDER(^AUPNPAT(DFN))
IF 'DFN
QUIT
Begin DoDot:1
+7 ;merged pt
IF '$DATA(^DPT(DFN))
QUIT
IF $PIECE(^(DFN,0),U,19)
QUIT
+8 SET (AGDONE,AGSITE)=0
+9 FOR
SET AGSITE=$ORDER(^AUPNPAT(DFN,41,AGSITE))
IF 'AGSITE
QUIT
Begin DoDot:2
+10 ;deleted or merged patient
IF $LENGTH($PIECE($GET(^AUPNPAT(DFN,41,AGSITE,0)),U,5))
IF "DM"[$PIECE(^(0),U,5)
QUIT
+11 SET AGFAC=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,10)
SET AGHRN="??????"
+12 IF $LENGTH($PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2))
SET AGHRN=$PIECE(^(0),U,2)
+13 IF '$TEST
IF $LENGTH($PIECE($GET(^AUPNPAT(DFN,41,AGSITE,0)),U,2))
SET AGHRN=$PIECE(^(0),U,2)
SET AGFAC=$PIECE($GET(^AUTTLOC(AGSITE,0)),U,10)
+14 DO CHK("PATIENT NAME : ",$PIECE($GET(^DPT(DFN,0)),U))
+15 DO CHK("EMERGENCY CONTACT : ",$PIECE($GET(^DPT(DFN,.33)),U))
+16 DO CHK("FATHER'S NAME : ",$PIECE($GET(^DPT(DFN,.24)),U))
+17 DO CHK("MOTHER'S MAIDEN NAME : ",$PIECE($GET(^DPT(DFN,.24)),U,3))
+18 DO CHK("NEXT OF KIN : ",$PIECE($GET(^DPT(DFN,.21)),U))
+19 DO MCD
+20 SET AG=0
+21 FOR
SET AG=$ORDER(^DPT(DFN,.01,AG))
IF 'AG
QUIT
DO CHK("OTHER NAME (ALIASES) : ",$PIECE($GET(^DPT(DFN,.01,AG,0)),U))
+22 SET AG=0
+23 FOR
SET AG=$ORDER(^AUPNPRVT(DFN,11,AG))
IF 'AG
QUIT
Begin DoDot:3
+24 DO CHK("NAME OF INSURED (PVT) : ",$PIECE($GET(^AUPNPRVT(DFN,11,AG,0)),U,4))
+25 DO NPH($PIECE($GET(^AUPNPRVT(DFN,11,AG,0)),U,8))
+26 QUIT
End DoDot:3
+27 ;pt is done, one and only one time
SET AGDONE=1
+28 QUIT
End DoDot:2
IF AGDONE
QUIT
+29 QUIT
End DoDot:1
IF '(DFN#1000)
IF '$DATA(ZTQUEUED)
WRITE !,"On IEN ",DFN," of ",AGP3," in ^AUPNPAT(..."
+30 NEW XMSUB,XMDUZ,XMTEXT,XMY
+31 SET XMSUB=$PIECE($PIECE($TEXT(+1),";",2)," ",3,99)
SET XMDUZ=$SELECT($GET(DUZ):DUZ,1:.5)
SET XMTEXT="^TMP(""AGEDNAME"",$J,"
SET XMY(1)=""
SET XMY(DUZ)=""
+32 FOR %="XUPROGMODE","AGZMENU","AGZMGR","ABMDZ TABLE MAINTENANCE","ABMDZ ELIGIBILITY EDIT","APCCZMGR"
DO SINGLE(%)
+33 DO ^XMD
+34 KILL ^TMP("AGEDNAME",$JOB)
+35 DO EN^XBVK("AG")
+36 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+37 WRITE !!,"The results are in your MailMan 'IN' basket.",!
+38 QUIT
MCD ;
+1 NEW D,N,S
+2 SET S=0
+3 FOR
SET S=$ORDER(^AUPNMCD("AB",DFN,S))
IF 'S
QUIT
SET N=0
Begin DoDot:1
+4 FOR
SET N=$ORDER(^AUPNMCD("AB",DFN,S,N))
IF 'N
QUIT
SET D=0
Begin DoDot:2
+5 FOR
SET D=$ORDER(^AUPNMCD("AB",DFN,S,N,D))
IF 'D
QUIT
Begin DoDot:3
+6 DO CHK("NAME OF INSURED (MCD) : ",$PIECE($GET(^AUPNMCD(D,0)),U,5))
+7 DO NPH($PIECE($GET(^AUPNMCD(D,0)),U,9))
+8 QUIT
End DoDot:3
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 QUIT
NPH(I) ;
+1 IF 'I
QUIT
+2 DO CHK("NAME OF POLICY HOLDER : ",$PIECE($GET(^AUPN3PPH(I,0)),U))
+3 QUIT
CHK(F,X) ;
+1 IF ((X="")!(X="SAME"))
QUIT
+2 NEW AG
+3 SET AG=X
+4 DO NAME^AUPNPED
+5 IF $DATA(X)
QUIT
+6 DO RSLT(F_U_AG)
+7 QUIT
RSLT(%) SET %=$JUSTIFY(AGFAC,6)_$JUSTIFY(AGHRN,8)_$JUSTIFY($PIECE(%,U,1),30)_"'"_$PIECE(%,U,2)_"'"
RSLT1 SET ^(0)=$GET(^TMP("AGEDNAME",$JOB,0))+1
SET ^(^(0))=%
IF '$DATA(ZTQUEUED)
WRITE !,%
+1 QUIT
OUT(%) DO RSLT1
QUIT
SINGLE(K) ;Get holders of a single key K.
+1 NEW Y
+2 SET Y=0
+3 IF '$DATA(^XUSEC(K))
QUIT
+4 FOR
SET Y=$ORDER(^XUSEC(K,Y))
IF 'Y
QUIT
SET XMY(Y)=""
+5 QUIT
