AGUTL ;IHS/OIT/NKD - PAT REG UTILITY ROUTINE ; FEBRUARY 10, 2014
;;7.1;PATIENT REGISTRATION;**11,12,13,14**;AUG 25, 2005;Build 1
;
;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
;IHS/OIT/NKD AG*7.1*11 VAMB
;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2
;
Q
RACE(AGPATDFN) ;EP - RETURN LIST OF PATIENT'S RACES (EXTERNAL FORMAT)
; # OF RACES^RACE 1^RACE 2^ETC
; EX: PT W/0 RACES => "0"
; EX: PT W/2 RACES => "2^AMERICAN INDIAN OR ALASKA NATIVE^ASIAN"
N AGRACE,AGLIST,AGCNT
D LIST^DIC(2.02,","_AGPATDFN_",","@;.01E","P",,,,,,,"AGRACE")
S AGLIST=$P(AGRACE("DILIST",0),"^",1)
F AGCNT=1:1:$P(AGRACE("DILIST",0),"^",1) S AGLIST=AGLIST_"^"_$P(AGRACE("DILIST",AGCNT,0),"^",2)
Q AGLIST
SEXELIG(AGPATDFN) ;EP - UPDATES PATIENT-SPECIFIC ELIGIBILITY SEX/GENDER FIELDS TO PATIENT'S SEX
; MEDICARE/MEDICAID/RAILROAD ELIGIBLE FILES ARE ASSOCIATED WITH A PATIENT
; CALLING THIS API WILL UPDATE THE SEX/GENDER FIELDS IN THE ELIGIBLE FILES TO MATCH THE PATIENT'S SEX
Q:'AGPATDFN
N AGSEX,AGPTR,AGPTR2
S AGSEX=$$GET1^DIQ(2,AGPATDFN,.02,"I")
Q:AGSEX']""
; MCR
S AGPTR=0 F S AGPTR=$O(^AUPNMCR("B",AGPATDFN,AGPTR)) Q:'AGPTR D
. Q:'$D(^AUPNMCR(AGPTR,0))
. Q:AGPATDFN'=$$GET1^DIQ(9000003,AGPTR,.01,"I")
. N FDA
. S AGPTR2=0 F S AGPTR2=$O(^AUPNMCR(AGPTR,11,AGPTR2)) Q:'AGPTR2 S FDA(9000003.11,AGPTR2_","_AGPTR_",",.08)=AGSEX
. I $D(FDA) D UPDATE^DIE(,"FDA")
; MCD
S AGPTR=0 F S AGPTR=$O(^AUPNMCD("B",AGPATDFN,AGPTR)) Q:'AGPTR D
. Q:'$D(^AUPNMCD(AGPTR,0))
. Q:AGPATDFN'=$$GET1^DIQ(9000004,AGPTR,.01,"I")
. N FDA
. S FDA(9000004,AGPTR_",",.07)=AGSEX
. D UPDATE^DIE(,"FDA")
; RRE
S AGPTR=0 F S AGPTR=$O(^AUPNRRE("B",AGPATDFN,AGPTR)) Q:'AGPTR D
. Q:'$D(^AUPNRRE(AGPTR,0))
. Q:AGPATDFN'=$$GET1^DIQ(9000005,AGPTR,.01,"I")
. N FDA
. S AGPTR2=0 F S AGPTR2=$O(^AUPNRRE(AGPTR,11,AGPTR2)) Q:'AGPTR2 S FDA(9000005.11,AGPTR2_","_AGPTR_",",.08)=AGSEX
. I $D(FDA) D UPDATE^DIE(,"FDA")
Q
;IHS/OIT/NKD AG*7.1*12 - START OLD CODE
;INSTYP(AGIEN) ;EP - RETURN INSURER TYPE CODE
;N AGRES
;S AGRES=$$GET1^DIQ(9999999.18,AGIEN,.211,"I")
;S AGRES=$$GET1^DIQ(9999999.181,AGRES,1,"I")
;Q AGRES
;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - CODE OPTIMIZATIONS
INSTYP(AGIEN,AGFLAG) ;EP - RETURN INSURER TYPE CODE (DEFAULT) OR NAME (AGFLAG=1)
S AGIEN=$G(AGIEN,0),AGFLAG=$G(AGFLAG,0) Q:'AGIEN "" Q:'$G(^AUTNINS(AGIEN,3)) "" Q $P($G(^AUTTINTY($G(^AUTNINS(AGIEN,3)),0)),"^",$S(AGFLAG:1,1:2))
;IHS/OIT/NKD AG*7.1*13
GETMCR(IEN,EFFDATE) ;EP - GET MEDICARE ELIGIBILITY NUMBER FOR A RECORD
; Call: $$GETMCR^AGUTL(IEN,EFFDATE)
; IEN: Medicare Eligibility record IEN
; EFFDATE: Defaults to TODAY
; Returned value:
; Successful (In the following order):
; MBI: If MBI exists as of EFFDATE
; HICN (MEDICARE ELIGIBLE #9000003): MEDICARE NUMBER (#.03)_SUFFIX (#.04)
; Unsuccessful:
; "": If neither MBI nor HICN
N FILE,DFN S FILE=9000003,IEN=+$G(IEN),EFFDATE=$G(EFFDATE,$$DT^XLFDT),DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
Q:$$HASMBI(DFN,EFFDATE) $$GETMBI^AUPNMBI(DFN,EFFDATE)
Q $$HICN(FILE,IEN)
;
GETRRE(IEN,EFFDATE) ;EP - GET RAILROAD ELIGIBILITY NUMBER FOR A RECORD
; Call: $$GETRRE^AGUTL(IEN,EFFDATE)
; IEN: Railroad Eligibility record IEN
; EFFDATE: Defaults to TODAY
; Returned value:
; Successful (In the following order):
; MBI: If MBI exists as of EFFDATE
; HICN (RAILROAD ELIGIBLE #9000005): PREFIX (#.03)_RAILROAD NUMBER (#.04)
; Unsuccessful:
; "": If neither MBI nor HICN
N FILE,DFN S FILE=9000005,IEN=+$G(IEN),EFFDATE=$G(EFFDATE,$$DT^XLFDT),DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
Q:$$HASMBI(DFN,EFFDATE) $$GETMBI^AUPNMBI(DFN,EFFDATE)
Q $$HICN(FILE,IEN)
;
HASMBI(DFN,EFFDATE) ;EP - CHECK IF PATIENT HAS MBI
; Call: $$HASMBI^AGUTL(DFN,EFFDATE)
; EFFDATE: Defaults to TODAY
; Returned value:
; Successful: 1
; Unsuccessful: 0
S DFN=+$G(DFN),EFFDATE=$G(EFFDATE,$$DT^XLFDT) Q:'DFN 0
Q ''$O(^AUPNPAT(DFN,44,EFFDATE+.000001),-1)
;
ISMBI(VAL) ;EP - CHECK IF THE INPUT IS A VALID MBI
; Returned value:
; Successful: MBI (VALIDATED)
; Unsuccessful: 0^SSN => INPUT MATCHED SSN FORMAT
; 0^MCR => INPUT MATCHED MCR HICN FORMAT
; 0^RRE => INPUT MATCHED RRE HICN FORMAT
; 0^ERROR MESSAGE OF MBI FORMAT
S VAL=$G(VAL)
Q:VAL?9N "0^SSN"
Q:VAL?9N.2A "0^MCR"
Q:VAL?.2A9N "0^RRE"
Q $$FORMOK^AUPNMBI(VAL)
;
HICN(FILE,IEN) ;EP - RETURNS THE HICN (MEDICARE AND RAILROAD)
Q ($$GET1^DIQ(FILE,IEN,.03)_$$GET1^DIQ(FILE,IEN,.04))
;
EDITMCR(IEN,FLAG) ;EP - INTERACTIVE EDIT OF MEDICARE NUMBER
N RES S IEN=+$G(IEN),FLAG=+$G(FLAG)
D EDITELIG(9000003,IEN)
I FLAG F S RES=$$GETMCR(IEN) Q:$L(RES) D
. D EDITELIG(9000003,IEN)
Q
;
EDITRRE(IEN,FLAG) ;EP - INTERACTIVE EDIT OF RAILROAD NUMBER
N RES S IEN=+$G(IEN),FLAG=+$G(FLAG)
D EDITELIG(9000005,IEN)
I FLAG F S RES=$$GETRRE(IEN) Q:$L(RES) D
. D EDITELIG(9000005,IEN)
Q
;
EDITELIG(FILE,IEN) ;EP - INTERACTIVE EDIT OF HICN AND MBI
N DFN,POL,RES S FILE=+$G(FILE),IEN=+$G(IEN),DFN=$$GET1^DIQ(FILE,IEN,.01,"I") Q:'DFN
S POL=$$ASKNUM(FILE,IEN),RES=$$ISMBI(POL) ;PROMPT USER RESPONSE AND DETERMINE FORMAT
I 'RES,"^SSN^MCR^RRE^"[(U_$P(RES,U,2)_U) S POL=$S(RES["MCR":$E(POL,1,9),RES["RRE":$E(POL,$L(POL)-8,$L(POL)),1:POL),POL=$$ASKHICN(FILE,IEN,POL) ;HICN FORMAT
E S POL=$$ASKMBI(DFN,POL,$S(FILE=9000003:"MCR",FILE=9000005:"RRE",1:"")) ;MBI FORMAT
Q
;
ASKNUM(FILE,IEN) ;PROMPT FOR HICN OR MBI AND RETURN USER RESPONSE
N DIR,X,Y,DFN,DEF
S IEN=+$G(IEN),FILE=+$G(FILE),DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
; INTERACTIVE ENTRY PROMPT
S DIR(0)="FA^9:11"
S DIR("A")=$S(FILE=9000003:"MEDICARE",FILE=9000005:"RAILROAD",1:"")_" NUMBER: "
S DIR("A",1)="The HICN or MBI may be entered at this prompt."
S DIR("A",2)=" HICN: The "_$S(FILE=9000003:"SUF",FILE=9000005:"PRE",1:"")_"FIX will be prompted for next."
S DIR("A",3)=" MBI: The EFFECTIVE DATE will be prompted for next."
S DIR("A",4)=""
S DIR("A",5)=" CURRENT HICN: "_$$HICN(FILE,IEN)
S DIR("A",6)=" CURRENT MBI: "_$S($$HASMBI(DFN):$$GETMBI^AUPNMBI(DFN,$$DT^XLFDT),1:"")
S DIR("A",7)=""
; DEFAULT (IF APPLICABLE)
S DEF=$$HICN(FILE,IEN) S:FILE=9000003 DEF=$E(DEF,1,9) S:FILE=9000005 DEF=$E(DEF,$L(DEF)-8,$L(DEF))
S:$$HASMBI(DFN) DEF=$$GETMBI^AUPNMBI(DFN,$$DT^XLFDT)
S:$L(DEF) DIR("B")=DEF
D ^DIR
Q $G(X)
;
ASKHICN(FILE,IEN,VAL) ;PROMPT FOR PREFIX/SUFFIX, STORE HICN, AND RETURN HICN
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
N DIE,DR,DA
S IEN=+$G(IEN),FILE=+$G(FILE),VAL=$G(VAL)
S DIE=$$GET1^DID(FILE,,,"GLOBAL NAME")
S DR=".03"_$S(FILE=9000003:"////"_VAL,1:"")_";.04"_$S(FILE=9000005:"////"_VAL,1:"") ; STUFF HICN AND ASK FOR PREFIX/SUFFIX
S DA=IEN
D ^DIE
Q $$HICN(FILE,IEN)
;
ASKMBI(IEN,VAL,SRC) ;VALIDATE MBI, PROMPT FOR EFFECTIVE DATE, STORE ENTRY, RETURN MBI
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
N RES,MBI,DIR,EFFDT
S IEN=+$G(IEN),MBI=$G(VAL),SRC=$G(SRC,"OTH"),RES=$$FORMOK^AUPNMBI(MBI)
; VALIDATE MBI FORMAT
I 'RES W !,$P(RES,U,2),! S DIR(0)="9000001.44,1" D ^DIR S MBI=$G(Y)
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
; ASK FOR EFFECTIVE DATE
K DIR
;S DIR(0)="DA" ;IHS/OIT/NKD AG*7.1*14 DON'T ALLOW FUTURE DATES
S DIR(0)="DA^:DT"
S DIR("A")="EFFECTIVE DATE: "
;S DIR("B")=$$FMTE^XLFDT($O(^AUPNPAT(IEN,44,"C",MBI,""),-1),5) ; DEFAULT TO MOST RECENT DATE IF MBI EXISTS ;IHS/OIT/NKD AG*7.1*14 DON'T DEFAULT TO FUTURE DATES
S DIR("B")=$$FMTE^XLFDT($O(^AUPNPAT(IEN,44,"C",MBI,$$DT^XLFDT+.000001),-1),5) ; DEFAULT TO MOST RECENT DATE IN THE PAST IF MBI EXISTS
S:'$L(DIR("B")) DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,5) ; OTHERWISE DEFAULT TO TODAY
D ^DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
S EFFDT=$P(+$G(Y),".")
; ADD MBI WITH SOURCE
Q $$ADDMBI^AUPNMBI(IEN,EFFDT,MBI,SRC)
;
;IHS/OIT/NKD AG*7.1*14
GETMBIS(IEN,RES,SUB) ;EP - RETURN FORMATTED LIST OF PATIENT MBI HISTORY
N TMP S IEN=+$G(IEN),RES=$G(RES),SUB=$G(SUB)
D LIST^DIC(9000001.44,","_IEN_",","@;.01;1;2;3;4","P","","","","","","","TMP")
I $L(SUB) M @RES@(SUB)=TMP("DILIST") K @RES@(SUB,0)
E M @RES=TMP("DILIST") K @RES@(0)
Q +TMP("DILIST",0)
;
AGUTL ;IHS/OIT/NKD - PAT REG UTILITY ROUTINE ; FEBRUARY 10, 2014
+1 ;;7.1;PATIENT REGISTRATION;**11,12,13,14**;AUG 25, 2005;Build 1
+2 ;
+3 ;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
+4 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
+5 ;IHS/OIT/NKD AG*7.1*11 VAMB
+6 ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
+7 ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
+8 ;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2
+9 ;
+10 QUIT
RACE(AGPATDFN) ;EP - RETURN LIST OF PATIENT'S RACES (EXTERNAL FORMAT)
+1 ; # OF RACES^RACE 1^RACE 2^ETC
+2 ; EX: PT W/0 RACES => "0"
+3 ; EX: PT W/2 RACES => "2^AMERICAN INDIAN OR ALASKA NATIVE^ASIAN"
+4 NEW AGRACE,AGLIST,AGCNT
+5 DO LIST^DIC(2.02,","_AGPATDFN_",","@;.01E","P",,,,,,,"AGRACE")
+6 SET AGLIST=$PIECE(AGRACE("DILIST",0),"^",1)
+7 FOR AGCNT=1:1:$PIECE(AGRACE("DILIST",0),"^",1)
SET AGLIST=AGLIST_"^"_$PIECE(AGRACE("DILIST",AGCNT,0),"^",2)
+8 QUIT AGLIST
SEXELIG(AGPATDFN) ;EP - UPDATES PATIENT-SPECIFIC ELIGIBILITY SEX/GENDER FIELDS TO PATIENT'S SEX
+1 ; MEDICARE/MEDICAID/RAILROAD ELIGIBLE FILES ARE ASSOCIATED WITH A PATIENT
+2 ; CALLING THIS API WILL UPDATE THE SEX/GENDER FIELDS IN THE ELIGIBLE FILES TO MATCH THE PATIENT'S SEX
+3 IF 'AGPATDFN
QUIT
+4 NEW AGSEX,AGPTR,AGPTR2
+5 SET AGSEX=$$GET1^DIQ(2,AGPATDFN,.02,"I")
+6 IF AGSEX']""
QUIT
+7 ; MCR
+8 SET AGPTR=0
FOR
SET AGPTR=$ORDER(^AUPNMCR("B",AGPATDFN,AGPTR))
IF 'AGPTR
QUIT
Begin DoDot:1
+9 IF '$DATA(^AUPNMCR(AGPTR,0))
QUIT
+10 IF AGPATDFN'=$$GET1^DIQ(9000003,AGPTR,.01,"I")
QUIT
+11 NEW FDA
+12 SET AGPTR2=0
FOR
SET AGPTR2=$ORDER(^AUPNMCR(AGPTR,11,AGPTR2))
IF 'AGPTR2
QUIT
SET FDA(9000003.11,AGPTR2_","_AGPTR_",",.08)=AGSEX
+13 IF $DATA(FDA)
DO UPDATE^DIE(,"FDA")
End DoDot:1
+14 ; MCD
+15 SET AGPTR=0
FOR
SET AGPTR=$ORDER(^AUPNMCD("B",AGPATDFN,AGPTR))
IF 'AGPTR
QUIT
Begin DoDot:1
+16 IF '$DATA(^AUPNMCD(AGPTR,0))
QUIT
+17 IF AGPATDFN'=$$GET1^DIQ(9000004,AGPTR,.01,"I")
QUIT
+18 NEW FDA
+19 SET FDA(9000004,AGPTR_",",.07)=AGSEX
+20 DO UPDATE^DIE(,"FDA")
End DoDot:1
+21 ; RRE
+22 SET AGPTR=0
FOR
SET AGPTR=$ORDER(^AUPNRRE("B",AGPATDFN,AGPTR))
IF 'AGPTR
QUIT
Begin DoDot:1
+23 IF '$DATA(^AUPNRRE(AGPTR,0))
QUIT
+24 IF AGPATDFN'=$$GET1^DIQ(9000005,AGPTR,.01,"I")
QUIT
+25 NEW FDA
+26 SET AGPTR2=0
FOR
SET AGPTR2=$ORDER(^AUPNRRE(AGPTR,11,AGPTR2))
IF 'AGPTR2
QUIT
SET FDA(9000005.11,AGPTR2_","_AGPTR_",",.08)=AGSEX
+27 IF $DATA(FDA)
DO UPDATE^DIE(,"FDA")
End DoDot:1
+28 QUIT
+29 ;IHS/OIT/NKD AG*7.1*12 - START OLD CODE
+30 ;INSTYP(AGIEN) ;EP - RETURN INSURER TYPE CODE
+31 ;N AGRES
+32 ;S AGRES=$$GET1^DIQ(9999999.18,AGIEN,.211,"I")
+33 ;S AGRES=$$GET1^DIQ(9999999.181,AGRES,1,"I")
+34 ;Q AGRES
+35 ;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - CODE OPTIMIZATIONS
INSTYP(AGIEN,AGFLAG) ;EP - RETURN INSURER TYPE CODE (DEFAULT) OR NAME (AGFLAG=1)
+1 SET AGIEN=$GET(AGIEN,0)
SET AGFLAG=$GET(AGFLAG,0)
IF 'AGIEN
QUIT ""
IF '$GET(^AUTNINS(AGIEN,3))
QUIT ""
QUIT $PIECE($GET(^AUTTINTY($GET(^AUTNINS(AGIEN,3)),0)),"^",$SELECT(AGFLAG:1,1:2))
+2 ;IHS/OIT/NKD AG*7.1*13
GETMCR(IEN,EFFDATE) ;EP - GET MEDICARE ELIGIBILITY NUMBER FOR A RECORD
+1 ; Call: $$GETMCR^AGUTL(IEN,EFFDATE)
+2 ; IEN: Medicare Eligibility record IEN
+3 ; EFFDATE: Defaults to TODAY
+4 ; Returned value:
+5 ; Successful (In the following order):
+6 ; MBI: If MBI exists as of EFFDATE
+7 ; HICN (MEDICARE ELIGIBLE #9000003): MEDICARE NUMBER (#.03)_SUFFIX (#.04)
+8 ; Unsuccessful:
+9 ; "": If neither MBI nor HICN
+10 NEW FILE,DFN
SET FILE=9000003
SET IEN=+$GET(IEN)
SET EFFDATE=$GET(EFFDATE,$$DT^XLFDT)
SET DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
+11 IF $$HASMBI(DFN,EFFDATE)
QUIT $$GETMBI^AUPNMBI(DFN,EFFDATE)
+12 QUIT $$HICN(FILE,IEN)
+13 ;
GETRRE(IEN,EFFDATE) ;EP - GET RAILROAD ELIGIBILITY NUMBER FOR A RECORD
+1 ; Call: $$GETRRE^AGUTL(IEN,EFFDATE)
+2 ; IEN: Railroad Eligibility record IEN
+3 ; EFFDATE: Defaults to TODAY
+4 ; Returned value:
+5 ; Successful (In the following order):
+6 ; MBI: If MBI exists as of EFFDATE
+7 ; HICN (RAILROAD ELIGIBLE #9000005): PREFIX (#.03)_RAILROAD NUMBER (#.04)
+8 ; Unsuccessful:
+9 ; "": If neither MBI nor HICN
+10 NEW FILE,DFN
SET FILE=9000005
SET IEN=+$GET(IEN)
SET EFFDATE=$GET(EFFDATE,$$DT^XLFDT)
SET DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
+11 IF $$HASMBI(DFN,EFFDATE)
QUIT $$GETMBI^AUPNMBI(DFN,EFFDATE)
+12 QUIT $$HICN(FILE,IEN)
+13 ;
HASMBI(DFN,EFFDATE) ;EP - CHECK IF PATIENT HAS MBI
+1 ; Call: $$HASMBI^AGUTL(DFN,EFFDATE)
+2 ; EFFDATE: Defaults to TODAY
+3 ; Returned value:
+4 ; Successful: 1
+5 ; Unsuccessful: 0
+6 SET DFN=+$GET(DFN)
SET EFFDATE=$GET(EFFDATE,$$DT^XLFDT)
IF 'DFN
QUIT 0
+7 QUIT ''$ORDER(^AUPNPAT(DFN,44,EFFDATE+.000001),-1)
+8 ;
ISMBI(VAL) ;EP - CHECK IF THE INPUT IS A VALID MBI
+1 ; Returned value:
+2 ; Successful: MBI (VALIDATED)
+3 ; Unsuccessful: 0^SSN => INPUT MATCHED SSN FORMAT
+4 ; 0^MCR => INPUT MATCHED MCR HICN FORMAT
+5 ; 0^RRE => INPUT MATCHED RRE HICN FORMAT
+6 ; 0^ERROR MESSAGE OF MBI FORMAT
+7 SET VAL=$GET(VAL)
+8 IF VAL?9N
QUIT "0^SSN"
+9 IF VAL?9N.2A
QUIT "0^MCR"
+10 IF VAL?.2A9N
QUIT "0^RRE"
+11 QUIT $$FORMOK^AUPNMBI(VAL)
+12 ;
HICN(FILE,IEN) ;EP - RETURNS THE HICN (MEDICARE AND RAILROAD)
+1 QUIT ($$GET1^DIQ(FILE,IEN,.03)_$$GET1^DIQ(FILE,IEN,.04))
+2 ;
EDITMCR(IEN,FLAG) ;EP - INTERACTIVE EDIT OF MEDICARE NUMBER
+1 NEW RES
SET IEN=+$GET(IEN)
SET FLAG=+$GET(FLAG)
+2 DO EDITELIG(9000003,IEN)
+3 IF FLAG
FOR
SET RES=$$GETMCR(IEN)
IF $LENGTH(RES)
QUIT
Begin DoDot:1
+4 DO EDITELIG(9000003,IEN)
End DoDot:1
+5 QUIT
+6 ;
EDITRRE(IEN,FLAG) ;EP - INTERACTIVE EDIT OF RAILROAD NUMBER
+1 NEW RES
SET IEN=+$GET(IEN)
SET FLAG=+$GET(FLAG)
+2 DO EDITELIG(9000005,IEN)
+3 IF FLAG
FOR
SET RES=$$GETRRE(IEN)
IF $LENGTH(RES)
QUIT
Begin DoDot:1
+4 DO EDITELIG(9000005,IEN)
End DoDot:1
+5 QUIT
+6 ;
EDITELIG(FILE,IEN) ;EP - INTERACTIVE EDIT OF HICN AND MBI
+1 NEW DFN,POL,RES
SET FILE=+$GET(FILE)
SET IEN=+$GET(IEN)
SET DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
IF 'DFN
QUIT
+2 ;PROMPT USER RESPONSE AND DETERMINE FORMAT
SET POL=$$ASKNUM(FILE,IEN)
SET RES=$$ISMBI(POL)
+3 ;HICN FORMAT
IF 'RES
IF "^SSN^MCR^RRE^"[(U_$PIECE(RES,U,2)_U)
SET POL=$SELECT(RES["MCR":$EXTRACT(POL,1,9),RES["RRE":$EXTRACT(POL,$LENGTH(POL)-8,$LENGTH(POL)),1:POL)
SET POL=$$ASKHICN(FILE,IEN,POL)
+4 ;MBI FORMAT
IF '$TEST
SET POL=$$ASKMBI(DFN,POL,$SELECT(FILE=9000003:"MCR",FILE=9000005:"RRE",1:""))
+5 QUIT
+6 ;
ASKNUM(FILE,IEN) ;PROMPT FOR HICN OR MBI AND RETURN USER RESPONSE
+1 NEW DIR,X,Y,DFN,DEF
+2 SET IEN=+$GET(IEN)
SET FILE=+$GET(FILE)
SET DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
+3 ; INTERACTIVE ENTRY PROMPT
+4 SET DIR(0)="FA^9:11"
+5 SET DIR("A")=$SELECT(FILE=9000003:"MEDICARE",FILE=9000005:"RAILROAD",1:"")_" NUMBER: "
+6 SET DIR("A",1)="The HICN or MBI may be entered at this prompt."
+7 SET DIR("A",2)=" HICN: The "_$SELECT(FILE=9000003:"SUF",FILE=9000005:"PRE",1:"")_"FIX will be prompted for next."
+8 SET DIR("A",3)=" MBI: The EFFECTIVE DATE will be prompted for next."
+9 SET DIR("A",4)=""
+10 SET DIR("A",5)=" CURRENT HICN: "_$$HICN(FILE,IEN)
+11 SET DIR("A",6)=" CURRENT MBI: "_$SELECT($$HASMBI(DFN):$$GETMBI^AUPNMBI(DFN,$$DT^XLFDT),1:"")
+12 SET DIR("A",7)=""
+13 ; DEFAULT (IF APPLICABLE)
+14 SET DEF=$$HICN(FILE,IEN)
IF FILE=9000003
SET DEF=$EXTRACT(DEF,1,9)
IF FILE=9000005
SET DEF=$EXTRACT(DEF,$LENGTH(DEF)-8,$LENGTH(DEF))
+15 IF $$HASMBI(DFN)
SET DEF=$$GETMBI^AUPNMBI(DFN,$$DT^XLFDT)
+16 IF $LENGTH(DEF)
SET DIR("B")=DEF
+17 DO ^DIR
+18 QUIT $GET(X)
+19 ;
ASKHICN(FILE,IEN,VAL) ;PROMPT FOR PREFIX/SUFFIX, STORE HICN, AND RETURN HICN
+1 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT ""
+2 NEW DIE,DR,DA
+3 SET IEN=+$GET(IEN)
SET FILE=+$GET(FILE)
SET VAL=$GET(VAL)
+4 SET DIE=$$GET1^DID(FILE,,,"GLOBAL NAME")
+5 ; STUFF HICN AND ASK FOR PREFIX/SUFFIX
SET DR=".03"_$SELECT(FILE=9000003:"////"_VAL,1:"")_";.04"_$SELECT(FILE=9000005:"////"_VAL,1:"")
+6 SET DA=IEN
+7 DO ^DIE
+8 QUIT $$HICN(FILE,IEN)
+9 ;
ASKMBI(IEN,VAL,SRC) ;VALIDATE MBI, PROMPT FOR EFFECTIVE DATE, STORE ENTRY, RETURN MBI
+1 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT ""
+2 NEW RES,MBI,DIR,EFFDT
+3 SET IEN=+$GET(IEN)
SET MBI=$GET(VAL)
SET SRC=$GET(SRC,"OTH")
SET RES=$$FORMOK^AUPNMBI(MBI)
+4 ; VALIDATE MBI FORMAT
+5 IF 'RES
WRITE !,$PIECE(RES,U,2),!
SET DIR(0)="9000001.44,1"
DO ^DIR
SET MBI=$GET(Y)
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT ""
+7 ; ASK FOR EFFECTIVE DATE
+8 KILL DIR
+9 ;S DIR(0)="DA" ;IHS/OIT/NKD AG*7.1*14 DON'T ALLOW FUTURE DATES
+10 SET DIR(0)="DA^:DT"
+11 SET DIR("A")="EFFECTIVE DATE: "
+12 ;S DIR("B")=$$FMTE^XLFDT($O(^AUPNPAT(IEN,44,"C",MBI,""),-1),5) ; DEFAULT TO MOST RECENT DATE IF MBI EXISTS ;IHS/OIT/NKD AG*7.1*14 DON'T DEFAULT TO FUTURE DATES
+13 ; DEFAULT TO MOST RECENT DATE IN THE PAST IF MBI EXISTS
SET DIR("B")=$$FMTE^XLFDT($ORDER(^AUPNPAT(IEN,44,"C",MBI,$$DT^XLFDT+.000001),-1),5)
+14 ; OTHERWISE DEFAULT TO TODAY
IF '$LENGTH(DIR("B"))
SET DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,5)
+15 DO ^DIR
+16 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT ""
+17 SET EFFDT=$PIECE(+$GET(Y),".")
+18 ; ADD MBI WITH SOURCE
+19 QUIT $$ADDMBI^AUPNMBI(IEN,EFFDT,MBI,SRC)
+20 ;
+21 ;IHS/OIT/NKD AG*7.1*14
GETMBIS(IEN,RES,SUB) ;EP - RETURN FORMATTED LIST OF PATIENT MBI HISTORY
+1 NEW TMP
SET IEN=+$GET(IEN)
SET RES=$GET(RES)
SET SUB=$GET(SUB)
+2 DO LIST^DIC(9000001.44,","_IEN_",","@;.01;1;2;3;4","P","","","","","","","TMP")
+3 IF $LENGTH(SUB)
MERGE @RES@(SUB)=TMP("DILIST")
KILL @RES@(SUB,0)
+4 IF '$TEST
MERGE @RES=TMP("DILIST")
KILL @RES@(0)
+5 QUIT +TMP("DILIST",0)
+6 ;
