Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGUTL

AGUTL.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 MULTIPLE RACES
  1.  ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
  1.  ;IHS/OIT/NKD AG*7.1*11 VAMB
  1.  ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
  1.  ;IHS/OIT/NKD AG*7.1*13 MBI IMPLEMENTATION
  1.  ;IHS/OIT/NKD AG*7.1*14 MBI PHASE 2
  1.  ;
  1.  Q
  1. RACE(AGPATDFN) ;EP - RETURN LIST OF PATIENT'S RACES (EXTERNAL FORMAT)
  1.  ; # OF RACES^RACE 1^RACE 2^ETC
  1.  ; EX: PT W/0 RACES => "0"
  1.  ; EX: PT W/2 RACES => "2^AMERICAN INDIAN OR ALASKA NATIVE^ASIAN"
  1.  N AGRACE,AGLIST,AGCNT
  1.  D LIST^DIC(2.02,","_AGPATDFN_",","@;.01E","P",,,,,,,"AGRACE")
  1.  S AGLIST=$P(AGRACE("DILIST",0),"^",1)
  1.  F AGCNT=1:1:$P(AGRACE("DILIST",0),"^",1) S AGLIST=AGLIST_"^"_$P(AGRACE("DILIST",AGCNT,0),"^",2)
  1.  Q AGLIST
  1. 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
  1.  ; CALLING THIS API WILL UPDATE THE SEX/GENDER FIELDS IN THE ELIGIBLE FILES TO MATCH THE PATIENT'S SEX
  1.  Q:'AGPATDFN
  1.  N AGSEX,AGPTR,AGPTR2
  1.  S AGSEX=$$GET1^DIQ(2,AGPATDFN,.02,"I")
  1.  Q:AGSEX']""
  1.  ; MCR
  1.  S AGPTR=0 F  S AGPTR=$O(^AUPNMCR("B",AGPATDFN,AGPTR)) Q:'AGPTR  D
  1.  . Q:'$D(^AUPNMCR(AGPTR,0))
  1.  . Q:AGPATDFN'=$$GET1^DIQ(9000003,AGPTR,.01,"I")
  1.  . N FDA
  1.  . S AGPTR2=0 F  S AGPTR2=$O(^AUPNMCR(AGPTR,11,AGPTR2)) Q:'AGPTR2  S FDA(9000003.11,AGPTR2_","_AGPTR_",",.08)=AGSEX
  1.  . I $D(FDA) D UPDATE^DIE(,"FDA")
  1.  ; MCD
  1.  S AGPTR=0 F  S AGPTR=$O(^AUPNMCD("B",AGPATDFN,AGPTR)) Q:'AGPTR  D
  1.  . Q:'$D(^AUPNMCD(AGPTR,0))
  1.  . Q:AGPATDFN'=$$GET1^DIQ(9000004,AGPTR,.01,"I")
  1.  . N FDA
  1.  . S FDA(9000004,AGPTR_",",.07)=AGSEX
  1.  . D UPDATE^DIE(,"FDA")
  1.  ; RRE
  1.  S AGPTR=0 F  S AGPTR=$O(^AUPNRRE("B",AGPATDFN,AGPTR)) Q:'AGPTR  D
  1.  . Q:'$D(^AUPNRRE(AGPTR,0))
  1.  . Q:AGPATDFN'=$$GET1^DIQ(9000005,AGPTR,.01,"I")
  1.  . N FDA
  1.  . S AGPTR2=0 F  S AGPTR2=$O(^AUPNRRE(AGPTR,11,AGPTR2)) Q:'AGPTR2  S FDA(9000005.11,AGPTR2_","_AGPTR_",",.08)=AGSEX
  1.  . I $D(FDA) D UPDATE^DIE(,"FDA")
  1.  Q
  1.  ;IHS/OIT/NKD AG*7.1*12 - START OLD CODE
  1.  ;INSTYP(AGIEN) ;EP - RETURN INSURER TYPE CODE
  1.  ;N AGRES
  1.  ;S AGRES=$$GET1^DIQ(9999999.18,AGIEN,.211,"I")
  1.  ;S AGRES=$$GET1^DIQ(9999999.181,AGRES,1,"I")
  1.  ;Q AGRES
  1.  ;IHS/OIT/NKD AG*7.1*12 - END OLD CODE - CODE OPTIMIZATIONS
  1. INSTYP(AGIEN,AGFLAG) ;EP - RETURN INSURER TYPE CODE (DEFAULT) OR NAME (AGFLAG=1)
  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))
  1.  ;IHS/OIT/NKD AG*7.1*13
  1. GETMCR(IEN,EFFDATE)  ;EP - GET MEDICARE ELIGIBILITY NUMBER FOR A RECORD
  1.  ; Call: $$GETMCR^AGUTL(IEN,EFFDATE)
  1.  ;  IEN: Medicare Eligibility record IEN
  1.  ;  EFFDATE: Defaults to TODAY
  1.  ; Returned value:
  1.  ;  Successful (In the following order):
  1.  ;   MBI: If MBI exists as of EFFDATE
  1.  ;   HICN (MEDICARE ELIGIBLE #9000003): MEDICARE NUMBER (#.03)_SUFFIX (#.04)
  1.  ;  Unsuccessful:
  1.  ;   "": If neither MBI nor HICN
  1.  N FILE,DFN S FILE=9000003,IEN=+$G(IEN),EFFDATE=$G(EFFDATE,$$DT^XLFDT),DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
  1.  Q:$$HASMBI(DFN,EFFDATE) $$GETMBI^AUPNMBI(DFN,EFFDATE)
  1.  Q $$HICN(FILE,IEN)
  1.  ;
  1. GETRRE(IEN,EFFDATE)  ;EP - GET RAILROAD ELIGIBILITY NUMBER FOR A RECORD
  1.  ; Call: $$GETRRE^AGUTL(IEN,EFFDATE)
  1.  ;  IEN: Railroad Eligibility record IEN
  1.  ;  EFFDATE: Defaults to TODAY
  1.  ; Returned value:
  1.  ;  Successful (In the following order):
  1.  ;   MBI: If MBI exists as of EFFDATE
  1.  ;   HICN (RAILROAD ELIGIBLE #9000005): PREFIX (#.03)_RAILROAD NUMBER (#.04)
  1.  ;  Unsuccessful:
  1.  ;   "": If neither MBI nor HICN
  1.  N FILE,DFN S FILE=9000005,IEN=+$G(IEN),EFFDATE=$G(EFFDATE,$$DT^XLFDT),DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
  1.  Q:$$HASMBI(DFN,EFFDATE) $$GETMBI^AUPNMBI(DFN,EFFDATE)
  1.  Q $$HICN(FILE,IEN)
  1.  ;
  1. HASMBI(DFN,EFFDATE)  ;EP - CHECK IF PATIENT HAS MBI
  1.  ; Call: $$HASMBI^AGUTL(DFN,EFFDATE)
  1.  ;  EFFDATE: Defaults to TODAY
  1.  ; Returned value:
  1.  ;  Successful: 1
  1.  ;  Unsuccessful: 0
  1.  S DFN=+$G(DFN),EFFDATE=$G(EFFDATE,$$DT^XLFDT) Q:'DFN 0
  1.  Q ''$O(^AUPNPAT(DFN,44,EFFDATE+.000001),-1)
  1.  ;
  1. ISMBI(VAL)  ;EP - CHECK IF THE INPUT IS A VALID MBI
  1.  ; Returned value:
  1.  ;  Successful: MBI (VALIDATED)
  1.  ;  Unsuccessful: 0^SSN  => INPUT MATCHED SSN FORMAT
  1.  ;                0^MCR  => INPUT MATCHED MCR HICN FORMAT
  1.  ;                0^RRE  => INPUT MATCHED RRE HICN FORMAT
  1.  ;                0^ERROR MESSAGE OF MBI FORMAT
  1.  S VAL=$G(VAL)
  1.  Q:VAL?9N "0^SSN"
  1.  Q:VAL?9N.2A "0^MCR"
  1.  Q:VAL?.2A9N "0^RRE"
  1.  Q $$FORMOK^AUPNMBI(VAL)
  1.  ;
  1. HICN(FILE,IEN)  ;EP - RETURNS THE HICN (MEDICARE AND RAILROAD)
  1.  Q ($$GET1^DIQ(FILE,IEN,.03)_$$GET1^DIQ(FILE,IEN,.04))
  1.  ;
  1. EDITMCR(IEN,FLAG)  ;EP - INTERACTIVE EDIT OF MEDICARE NUMBER
  1.  N RES S IEN=+$G(IEN),FLAG=+$G(FLAG)
  1.  D EDITELIG(9000003,IEN)
  1.  I FLAG F  S RES=$$GETMCR(IEN) Q:$L(RES)  D
  1.  . D EDITELIG(9000003,IEN)
  1.  Q
  1.  ;
  1. EDITRRE(IEN,FLAG)  ;EP - INTERACTIVE EDIT OF RAILROAD NUMBER
  1.  N RES S IEN=+$G(IEN),FLAG=+$G(FLAG)
  1.  D EDITELIG(9000005,IEN)
  1.  I FLAG F  S RES=$$GETRRE(IEN) Q:$L(RES)  D
  1.  . D EDITELIG(9000005,IEN)
  1.  Q
  1.  ;
  1. EDITELIG(FILE,IEN)  ;EP - INTERACTIVE EDIT OF HICN AND MBI
  1.  N DFN,POL,RES S FILE=+$G(FILE),IEN=+$G(IEN),DFN=$$GET1^DIQ(FILE,IEN,.01,"I") Q:'DFN
  1.  S POL=$$ASKNUM(FILE,IEN),RES=$$ISMBI(POL)  ;PROMPT USER RESPONSE AND DETERMINE FORMAT
  1.  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
  1.  E  S POL=$$ASKMBI(DFN,POL,$S(FILE=9000003:"MCR",FILE=9000005:"RRE",1:""))  ;MBI FORMAT
  1.  Q
  1.  ;
  1. ASKNUM(FILE,IEN)  ;PROMPT FOR HICN OR MBI AND RETURN USER RESPONSE
  1.  N DIR,X,Y,DFN,DEF
  1.  S IEN=+$G(IEN),FILE=+$G(FILE),DFN=$$GET1^DIQ(FILE,IEN,.01,"I")
  1.  ; INTERACTIVE ENTRY PROMPT
  1.  S DIR(0)="FA^9:11"
  1.  S DIR("A")=$S(FILE=9000003:"MEDICARE",FILE=9000005:"RAILROAD",1:"")_" NUMBER: "
  1.  S DIR("A",1)="The HICN or MBI may be entered at this prompt."
  1.  S DIR("A",2)="  HICN: The "_$S(FILE=9000003:"SUF",FILE=9000005:"PRE",1:"")_"FIX will be prompted for next."
  1.  S DIR("A",3)="   MBI: The EFFECTIVE DATE will be prompted for next."
  1.  S DIR("A",4)=""
  1.  S DIR("A",5)="  CURRENT HICN: "_$$HICN(FILE,IEN)
  1.  S DIR("A",6)="   CURRENT MBI: "_$S($$HASMBI(DFN):$$GETMBI^AUPNMBI(DFN,$$DT^XLFDT),1:"")
  1.  S DIR("A",7)=""
  1.  ; DEFAULT (IF APPLICABLE)
  1.  S DEF=$$HICN(FILE,IEN) S:FILE=9000003 DEF=$E(DEF,1,9) S:FILE=9000005 DEF=$E(DEF,$L(DEF)-8,$L(DEF))
  1.  S:$$HASMBI(DFN) DEF=$$GETMBI^AUPNMBI(DFN,$$DT^XLFDT)
  1.  S:$L(DEF) DIR("B")=DEF
  1.  D ^DIR
  1.  Q $G(X)
  1.  ;
  1. ASKHICN(FILE,IEN,VAL)  ;PROMPT FOR PREFIX/SUFFIX, STORE HICN, AND RETURN HICN
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
  1.  N DIE,DR,DA
  1.  S IEN=+$G(IEN),FILE=+$G(FILE),VAL=$G(VAL)
  1.  S DIE=$$GET1^DID(FILE,,,"GLOBAL NAME")
  1.  S DR=".03"_$S(FILE=9000003:"////"_VAL,1:"")_";.04"_$S(FILE=9000005:"////"_VAL,1:"")  ; STUFF HICN AND ASK FOR PREFIX/SUFFIX
  1.  S DA=IEN
  1.  D ^DIE
  1.  Q $$HICN(FILE,IEN)
  1.  ;
  1. ASKMBI(IEN,VAL,SRC)  ;VALIDATE MBI, PROMPT FOR EFFECTIVE DATE, STORE ENTRY, RETURN MBI
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
  1.  N RES,MBI,DIR,EFFDT
  1.  S IEN=+$G(IEN),MBI=$G(VAL),SRC=$G(SRC,"OTH"),RES=$$FORMOK^AUPNMBI(MBI)
  1.  ; VALIDATE MBI FORMAT
  1.  I 'RES W !,$P(RES,U,2),! S DIR(0)="9000001.44,1" D ^DIR S MBI=$G(Y)
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
  1.  ; ASK FOR EFFECTIVE DATE
  1.  K DIR
  1.  ;S DIR(0)="DA"  ;IHS/OIT/NKD AG*7.1*14 DON'T ALLOW FUTURE DATES
  1.  S DIR(0)="DA^:DT"
  1.  S DIR("A")="EFFECTIVE DATE: "
  1.  ;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
  1.  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
  1.  S:'$L(DIR("B")) DIR("B")=$$FMTE^XLFDT($$DT^XLFDT,5)  ; OTHERWISE DEFAULT TO TODAY
  1.  D ^DIR
  1.  Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
  1.  S EFFDT=$P(+$G(Y),".")
  1.  ; ADD MBI WITH SOURCE
  1.  Q $$ADDMBI^AUPNMBI(IEN,EFFDT,MBI,SRC)
  1.  ;
  1.  ;IHS/OIT/NKD AG*7.1*14
  1. GETMBIS(IEN,RES,SUB)  ;EP - RETURN FORMATTED LIST OF PATIENT MBI HISTORY
  1.  N TMP S IEN=+$G(IEN),RES=$G(RES),SUB=$G(SUB)
  1.  D LIST^DIC(9000001.44,","_IEN_",","@;.01;1;2;3;4","P","","","","","","","TMP")
  1.  I $L(SUB) M @RES@(SUB)=TMP("DILIST") K @RES@(SUB,0)
  1.  E  M @RES=TMP("DILIST") K @RES@(0)
  1.  Q +TMP("DILIST",0)
  1.  ;