AGGUL1 ;VNGT/HS/DLS - Miscellaneous AGG Utilities ; 08 Apr 2010 3:36 PM
;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
;
;
Q
;
FMTE(Y) ;EP - Convert Fileman Date/Time to 'MMM DD,CCYY HH:MM:SS' format.
;Description
; Receives Date (Y) in FileMan format and returns formatted date.
;
;Input
; Y - FileMan date/time (i.e. 3051024.123456).
;
;Output
; Date/Time in External format (i.e. OCT 24,2005 12:34:56).
;
NEW DATM
S DATM=$TR($$FMTE^DILIBF(Y,"5U"),"@"," ")
I DATM["24:00" S DATM=$P(DATM," ",1,2)_" 00:00"
Q DATM
;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
;Input
; DATE - In a standard format
;Output
; -1 is if it couldn't convert to a FileMan date
; otherwise a standard FileMan date
NEW %DT,X,Y
I DATE[":" D
. I DATE["/",$L(DATE," ")=3 S DATE=$P(DATE," ",1)_"@"_$P(DATE," ",2)_$P(DATE," ",3) Q
. I $L(DATE," ")=3 S DATE=$P(DATE," ",1,2)_"@"_$P(DATE," ",3)
. I $L(DATE," ")>3 S DATE=$P(DATE," ",1,3)_"@"_$P(DATE," ",4,99)
S %DT="TS",X=DATE D ^%DT
I Y=-1 S Y=""
;
Q Y
;
FMTMDY(DATE) ;EP - Convert fileman date to MM/DD/YYYY format
;Input
; DATE - In fileman format
;
;Output
; -1 if couldn't convert to MM/DD/YYYY format
; Otherwise, date in MM/DD/YYYY format
;
Q $TR($$FMTE^XLFDT(DATE,"5Z"),"@"," ")
;
TKO(STR,VAL) ;EP - Take off ending character
;
;Description
; This will take off the ending character at the end of
; a string
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; same STR without the ending character
;
I $G(STR)="" Q ""
I $G(VAL)="" Q ""
;
NEW LV
S LV=$L(VAL)
I $E(STR,$L(STR)-(LV-1),$L(STR))=VAL S STR=$E(STR,1,$L(STR)-LV)
;
Q STR
;
STRIP(STR,VAL) ;EP - Remove one or more trailing characters in a string.
;
;Description
; Removes one or more trailing characters
; at the end of a string.
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; Same STR without the trailing character(s).
;
I $G(STR)="" Q STR
I $G(VAL)="" Q STR
;
F Q:$E(STR,$L(STR))'=VAL S STR=$E(STR,1,($L(STR)-1))
Q STR
;
CTRL(X) ;EP - Strip out control characters
I X'?.ANP F Y=1:1 I $E(X,Y)?.C Q:Y>$L(X)!(X="") S X=$E(X,1,Y-1)_$E(X,Y+1,999),Y=Y-1
Q X
;
TRIM(STR,VAL) ;EP - Remove one or more leading characters in a string.
;
;Description
; Removes one or more leading characters from a string.
;Input
; STR - String of data
; VAL - Delimiter character
;Output
; Same STR without the trailing character(s).
;
I $G(STR)="" Q STR
I $G(VAL)="" Q STR
;
F Q:$E(STR,1)'=VAL S STR=$E(STR,2,($L(STR)))
Q STR
;
PTR(FIL,FLD,VVAL,VPEC) ;EP - Find alternate value for a pointer
;
; Input Parameters
; FIL = FileMan File #
; FLD = FileMan Field #
; VVAL = Data Value
; VPEC = Field from pointed to file, defaults to .01 if not defined
;
NEW ARR1,VEDATA,VFILN,VEHDTA,VVALUE,VVVAL
I $G(VPEC)="" S VPEC=.01
;
I $G(VVAL)="" Q ""
; Get the Pointer Global Reference
D FIELD^DID(FIL,FLD,"","POINTER","VEPAR")
S VEDATA=$G(VEPAR("POINTER")),VEHDTA="^"_VEDATA_"0)"
S VFILN=$P($G(@VEHDTA),U,2)
S VFILN=$$STRIP^XLFSTR(VFILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
K VEPAR
;
S VVVAL=$$GET1^DIQ(FIL,VVAL_",",FLD,"I") I VVVAL="" Q ""
S VVALUE=$$GET1^DIQ(VFILN,VVVAL_",",VPEC,"E")
;B D FIELD^DID(VFILN,VPEC,"N","GLOBAL SUBSCRIPT LOCATION","ARR")
;S ARR1=ARR("GLOBAL SUBSCRIPT LOCATION")
;
;I VVAL'="" S VEHDTA="^"_VEDATA_VVAL_","_$P(ARR1,";",1)_")"
;
;S PEC=$P(ARR1,";",2)
;I VVAL'="" S VVALUE=$P($G(@VEHDTA),U,PEC)
Q VVALUE
;
STC(FIL,FLD,VAL) ; EP - Find a value for a set of codes code
; Input Parameters
; FIL = FileMan File Number
; FLD = FileMan Field Number
; VAL = Code Value
;
NEW VEDATA,VEQFL,VEVL,VALUE
S VEDATA=$P(^DD(FIL,FLD,0),U,3),VEQFL=0
;
F I=1:1 S VEVL=$P(VEDATA,";",I) Q:VEVL="" D Q:VEQFL
. S VALUE=$P(VEVL,":",2) I VAL=$P(VEVL,":",1) S VEQFL=1
;
Q VALUE
;
TMPFL(MODE,UID,DFN) ;EP - Open to 'R'ead, Open to 'W'rite, 'C'lose or 'D'elete
; temporary file designed for use when converting report text to RPC
; data strings. Note that UID and DFN are components of the file name.
;
; Input
; MODE(Required) - 'R'(Read),'W'(Write),'C'(Close),'D'(Delete)
; UID(Req'd for modes D,R,W) - Job identifier
; DFN(Req'd for modes D,R,W) - Patient IEN
; Output
; POP - 0 for success, 1 for failure
;
N POP,HSPATH,HSFN
S POP=1
;
; To close a file.
I MODE="C" D CLOSE^%ZISH("AGGFILE")
;
; To Delete, Read-From, or Write-To a file.
I "D/R/W"[MODE D
.S HSPATH=$$DEFDIR^%ZISH("")
.I HSPATH="" S HSPATH=$$PWD^%ZISH()
.S HSFN=UID_"_"_$G(DFN)_".DAT"
;
; To delete a file
I MODE="D" S POP=$$DEL^%ZISH(HSPATH,HSFN)
;
; To Read from or to Write to a file.
I (MODE="R")!(MODE="W") D
.D OPEN^%ZISH("AGGFILE",HSPATH,HSFN,MODE)
Q POP
;
HRN(DFN) ;EP - Patient Health Record Number
;
;Description
; Returns the patient's health record number
;Input
; DFN - Patient internal entry number
; DUZ(2) - Assumes DUZ(2) exists since it's defined by
; signing on to the system as the user's default
; facility
;Output
; HRN - Health Record number for the user's default
; facility
;
I $G(DUZ(2))="" Q ""
I $G(DFN)="" Q ""
;
NEW HRN
S HRN=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
I $P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)'="" S HRN="*"_HRN
Q HRN
;
HRNL(DFN,LOC) ;PEP - Patient's Health Record Number
; Input
; DFN - Patient's internal entry number
; LOC - Facility internal entry number (so does not depend on DUZ(2)
;
I $G(LOC)="" Q ""
I $G(DFN)="" Q ""
NEW HRN
S HRN=$P($G(^AUPNPAT(DFN,41,LOC,0)),U,2)
I $P($G(^AUPNPAT(DFN,41,LOC,0)),U,3)'="" S HRN="*"_HRN
Q HRN
;
SENS(DFN) ;EP - Is patient sensitive flag
;Input
; DFN - Patient internal entry number
NEW FLAG
S FLAG=+$P($G(^DGSL(38.1,+DFN,0)),"^",2)
S FLAG=$S(FLAG=1:"YES",1:"NO")
Q FLAG
;
CTY(DFN) ;EP - Combines city,state and zip
NEW ADATA,RESULT,STN,AZIP,LZIP
S ADATA=$G(^DPT(DFN,.11)) I ADATA="" Q ""
S RESULT=$P(ADATA,U,4)
I RESULT'="" S RESULT=RESULT_", "
S STN=$P(ADATA,U,5)
I STN'="" S RESULT=RESULT_$P(^DIC(5,STN,0),U,2)_" "
S AZIP=$P(ADATA,U,6)
S LZIP=$P(ADATA,U,12)
S RESULT=RESULT_$S(LZIP'="":LZIP,1:AZIP)
Q RESULT
;
CHS(DFN,PAIR) ;EP - CHS Eligibility
NEW C0,RESULT
S C0=0,RESULT=""
S C0=$O(^AUPNPAT(DFN,34,C0)) I 'C0 Q RESULT D
. I $G(PAIR)=1 S RESULT=C0_$C(28)_$P($G(^AUPNELM(C0,0)),U,1) Q
. S RESULT=$P($G(^AUPNELM(C0,0)),U,1)
Q RESULT
;
ALT(DFN) ;EP - Alternate Resources
NEW RESULT,AGINSN1,AGINS,AGCAT,ISACTIVE,AGGUAR,AGSEL,AOPCOINS
NEW DATEINEF,FIXLIST,INSGEND,MEDCARE,NEWSEQR,PHREC,POLH,RAILROAD
NEW REC,RELPOLHO,SPECSUB,TRUEPOLH,AGINSNN,PLANNAME,PLANPTR,MAX
NEW GRPNUMB,COINS,ENTDAT,EFF,END
D EP^AGINS
D LOADCAT^AGCAT
S ISACTIVE=0
S N=0
F S N=$O(AGINS(N)) Q:N="" D
. S EFF=$P(AGINS(N),U,5),END=$P(AGINS(N),U,6)
. I $$ISACTIVE^AGINSUPD(EFF,END) S ISACTIVE=1
I 'ISACTIVE S RESULT="NO"
I ISACTIVE S RESULT="YES"
Q RESULT
;
MREC(DFN) ;EP - Status of Medical Record
NEW RESULT,VAL
S VAL=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,4)
I VAL="" Q ""
Q VAL_$C(28)_$P(^AUTTDIS(VAL,0),U,1)
;
AOB(DFN) ;EP - Assign of Benefits
NEW RESULT,DATE
S DATE=""
S DATE=$O(^AUPNPAT(DFN,71,"B",DATE),-1)
I 'DATE Q ""
Q $$FMTE^AGGUL1(DATE)
;
ROI(DFN) ;EP - Release of Information
NEW RESULT,DATE
S DATE=""
S DATE=$O(^AUPNPAT(DFN,36,"B",DATE),-1)
I 'DATE Q ""
Q $$FMTE^AGGUL1(DATE)
;
ADR(PATDFN,FORCE) ; EP - Update PREVIOUS MAIL ADDRESSES
; Copied and modified from AGUTILS
S FORCE=$G(FORCE)
; Quit if they already have a historical address
I FORCE="F" Q:$O(^AUPNPAT(PATDFN,83,0))
NEW ADDREC,DIE,DIC,DR,DA
S DA(1)=PATDFN
S DIC="^AUPNPAT("_DA(1)_",83,"
S DIC(0)="L"
S X=""""_DT_""""
D ^DIC
I Y<0 Q
S ADDREC=+Y
;
;get the current ADDRESS VALUES
NEW AGSTR1,AGSTR2,AGSTR3,AGCITY,AGSTATE,AGZIP,AGHPHONE
S AGSTR1=$$GET1^DIQ(2,PATDFN_",",.111)
S AGSTR2=$$GET1^DIQ(2,PATDFN_",",.112)
S AGSTR3=$$GET1^DIQ(2,PATDFN_",",.113)
S AGCITY=$$GET1^DIQ(2,PATDFN_",",.114)
S AGSTATE=$$GET1^DIQ(2,PATDFN_",",.115)
I $G(AGSTATE)'="" I AGSTATE'=+AGSTATE S AGSTATE=$O(^DIC(5,"B",AGSTATE,""))
S AGZIP=$S($$GET1^DIQ(2,PATDFN_",",.1112,"E")'="":$$GET1^DIQ(2,PATDFN_",",.1112,"E"),1:$$GET1^DIQ(2,PATDFN_",",.116))
S AGHPHONE=$$GET1^DIQ(2,PATDFN_",",.131)
;
K DIE,DIC,DR,DA,DIR
S DA=ADDREC,DA(1)=PATDFN,IENS=$$IENS^DILF(.DA)
S DIE="^AUPNPAT("_DA(1)_",83,"
I FORCE="F" D
. S AGGUPD(9000001.83,IENS,.02)="AGSTR1",AGGUPD(9000001.83,IENS,.03)="AGSTR2",AGGUPD(9000001.83,IENS,.04)="AGSTR3"
. S AGGUPD(9000001.83,IENS,.05)="AGCITY",AGGUPD(9000001.83,IENS,.06)="AGSTATE",AGGUPD(9000001.83,IENS,.07)="AGZIP"
. S AGGUPD(9000001.83,IENS,.08)="AGHPHONE"
. ;S DR=".02////AGSTR1;.03////AGSTR2;.04////AGSTR3;.05////AGCITY;.06////AGSTATE;.07////AGZIP;.08////AGHPHONE"
I FORCE'="F" D
. S AGGUPD(9000001.83,IENS,.02)=AGSTR1,AGGUPD(9000001.83,IENS,.03)=AGSTR2,AGGUPD(9000001.83,IENS,.04)=AGSTR3
. S AGGUPD(9000001.83,IENS,.05)=AGCITY,AGGUPD(9000001.83,IENS,.06)=AGSTATE,AGGUPD(9000001.83,IENS,.07)=AGZIP
. S AGGUPD(9000001.83,IENS,.08)=AGHPHONE
. ;S DR=".02///^S X=AGSTR1;.03///^S X=AGSTR2;.04///^S X=AGSTR3;.05///^S X=AGCITY;.06///^S X=AGSTATE;.07///^S X=AGZIP;.08///^S X=AGHPHONE"
D FILE^DIE("","AGGUPD","ERROR")
Q
;
EML(DFN) ; EP - Update PREVIOUS EMAIL ADDRESSES
NEW ADDREC,DIE,DIC,DR,DA,AGEMAIL,AGGUPD,ERROR
S DA(1)=DFN
S DIC="^AUPNPAT("_DA(1)_",82,"
S DIC(0)="L"
S X=""""_DT_""""
D ^DIC
I Y<0 Q
S ADDREC=+Y
S AGEMAIL=$$GET1^DIQ(9000001,DFN_",",1802) I AGEMAIL="" Q
S DA=ADDREC,DA(1)=DFN,IENS=$$IENS^DILF(.DA)
S AGGUPD(9000001.82,IENS,.02)=AGEMAIL
D FILE^DIE("","AGGUPD","ERROR")
Q
;
TRIB(DFN) ; EP - Get list of other tribes
NEW RESULT,DA,IENS
S RESULT=""
S DA(1)=DFN,DA=0
F S DA=$O(^AUPNPAT(DFN,43,DA)) Q:'DA D
. S IENS=$$IENS^DILF(.DA)
. S RESULT=RESULT_$$GET1^DIQ(9000001.43,IENS,.01,"E")_";"
S RESULT=$$TKO^AGGUL1(RESULT,";")
I RESULT="" S RESULT="NONE LISTED"
Q RESULT
AGGUL1 ;VNGT/HS/DLS - Miscellaneous AGG Utilities ; 08 Apr 2010 3:36 PM
+1 ;;1.0;PATIENT REGISTRATION GUI;;Nov 15, 2010
+2 ;
+3 ;
+4 QUIT
+5 ;
FMTE(Y) ;EP - Convert Fileman Date/Time to 'MMM DD,CCYY HH:MM:SS' format.
+1 ;Description
+2 ; Receives Date (Y) in FileMan format and returns formatted date.
+3 ;
+4 ;Input
+5 ; Y - FileMan date/time (i.e. 3051024.123456).
+6 ;
+7 ;Output
+8 ; Date/Time in External format (i.e. OCT 24,2005 12:34:56).
+9 ;
+10 NEW DATM
+11 SET DATM=$TRANSLATE($$FMTE^DILIBF(Y,"5U"),"@"," ")
+12 IF DATM["24:00"
SET DATM=$PIECE(DATM," ",1,2)_" 00:00"
+13 QUIT DATM
+14 ;
DATE(DATE) ;EP - Convert standard date/time to a FileMan date/time
+1 ;Input
+2 ; DATE - In a standard format
+3 ;Output
+4 ; -1 is if it couldn't convert to a FileMan date
+5 ; otherwise a standard FileMan date
+6 NEW %DT,X,Y
+7 IF DATE[":"
Begin DoDot:1
+8 IF DATE["/"
IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1)_"@"_$PIECE(DATE," ",2)_$PIECE(DATE," ",3)
QUIT
+9 IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1,2)_"@"_$PIECE(DATE," ",3)
+10 IF $LENGTH(DATE," ")>3
SET DATE=$PIECE(DATE," ",1,3)_"@"_$PIECE(DATE," ",4,99)
End DoDot:1
+11 SET %DT="TS"
SET X=DATE
DO ^%DT
+12 IF Y=-1
SET Y=""
+13 ;
+14 QUIT Y
+15 ;
FMTMDY(DATE) ;EP - Convert fileman date to MM/DD/YYYY format
+1 ;Input
+2 ; DATE - In fileman format
+3 ;
+4 ;Output
+5 ; -1 if couldn't convert to MM/DD/YYYY format
+6 ; Otherwise, date in MM/DD/YYYY format
+7 ;
+8 QUIT $TRANSLATE($$FMTE^XLFDT(DATE,"5Z"),"@"," ")
+9 ;
TKO(STR,VAL) ;EP - Take off ending character
+1 ;
+2 ;Description
+3 ; This will take off the ending character at the end of
+4 ; a string
+5 ;Input
+6 ; STR - String of data
+7 ; VAL - Delimiter character
+8 ;Output
+9 ; same STR without the ending character
+10 ;
+11 IF $GET(STR)=""
QUIT ""
+12 IF $GET(VAL)=""
QUIT ""
+13 ;
+14 NEW LV
+15 SET LV=$LENGTH(VAL)
+16 IF $EXTRACT(STR,$LENGTH(STR)-(LV-1),$LENGTH(STR))=VAL
SET STR=$EXTRACT(STR,1,$LENGTH(STR)-LV)
+17 ;
+18 QUIT STR
+19 ;
STRIP(STR,VAL) ;EP - Remove one or more trailing characters in a string.
+1 ;
+2 ;Description
+3 ; Removes one or more trailing characters
+4 ; at the end of a string.
+5 ;Input
+6 ; STR - String of data
+7 ; VAL - Delimiter character
+8 ;Output
+9 ; Same STR without the trailing character(s).
+10 ;
+11 IF $GET(STR)=""
QUIT STR
+12 IF $GET(VAL)=""
QUIT STR
+13 ;
+14 FOR
IF $EXTRACT(STR,$LENGTH(STR))'=VAL
QUIT
SET STR=$EXTRACT(STR,1,($LENGTH(STR)-1))
+15 QUIT STR
+16 ;
CTRL(X) ;EP - Strip out control characters
+1 IF X'?.ANP
FOR Y=1:1
IF $EXTRACT(X,Y)?.C
IF Y>$LENGTH(X)!(X="")
QUIT
SET X=$EXTRACT(X,1,Y-1)_$EXTRACT(X,Y+1,999)
SET Y=Y-1
+2 QUIT X
+3 ;
TRIM(STR,VAL) ;EP - Remove one or more leading characters in a string.
+1 ;
+2 ;Description
+3 ; Removes one or more leading characters from a string.
+4 ;Input
+5 ; STR - String of data
+6 ; VAL - Delimiter character
+7 ;Output
+8 ; Same STR without the trailing character(s).
+9 ;
+10 IF $GET(STR)=""
QUIT STR
+11 IF $GET(VAL)=""
QUIT STR
+12 ;
+13 FOR
IF $EXTRACT(STR,1)'=VAL
QUIT
SET STR=$EXTRACT(STR,2,($LENGTH(STR)))
+14 QUIT STR
+15 ;
PTR(FIL,FLD,VVAL,VPEC) ;EP - Find alternate value for a pointer
+1 ;
+2 ; Input Parameters
+3 ; FIL = FileMan File #
+4 ; FLD = FileMan Field #
+5 ; VVAL = Data Value
+6 ; VPEC = Field from pointed to file, defaults to .01 if not defined
+7 ;
+8 NEW ARR1,VEDATA,VFILN,VEHDTA,VVALUE,VVVAL
+9 IF $GET(VPEC)=""
SET VPEC=.01
+10 ;
+11 IF $GET(VVAL)=""
QUIT ""
+12 ; Get the Pointer Global Reference
+13 DO FIELD^DID(FIL,FLD,"","POINTER","VEPAR")
+14 SET VEDATA=$GET(VEPAR("POINTER"))
SET VEHDTA="^"_VEDATA_"0)"
+15 SET VFILN=$PIECE($GET(@VEHDTA),U,2)
+16 SET VFILN=$$STRIP^XLFSTR(VFILN,"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
+17 KILL VEPAR
+18 ;
+19 SET VVVAL=$$GET1^DIQ(FIL,VVAL_",",FLD,"I")
IF VVVAL=""
QUIT ""
+20 SET VVALUE=$$GET1^DIQ(VFILN,VVVAL_",",VPEC,"E")
+21 ;B D FIELD^DID(VFILN,VPEC,"N","GLOBAL SUBSCRIPT LOCATION","ARR")
+22 ;S ARR1=ARR("GLOBAL SUBSCRIPT LOCATION")
+23 ;
+24 ;I VVAL'="" S VEHDTA="^"_VEDATA_VVAL_","_$P(ARR1,";",1)_")"
+25 ;
+26 ;S PEC=$P(ARR1,";",2)
+27 ;I VVAL'="" S VVALUE=$P($G(@VEHDTA),U,PEC)
+28 QUIT VVALUE
+29 ;
STC(FIL,FLD,VAL) ; EP - Find a value for a set of codes code
+1 ; Input Parameters
+2 ; FIL = FileMan File Number
+3 ; FLD = FileMan Field Number
+4 ; VAL = Code Value
+5 ;
+6 NEW VEDATA,VEQFL,VEVL,VALUE
+7 SET VEDATA=$PIECE(^DD(FIL,FLD,0),U,3)
SET VEQFL=0
+8 ;
+9 FOR I=1:1
SET VEVL=$PIECE(VEDATA,";",I)
IF VEVL=""
QUIT
Begin DoDot:1
+10 SET VALUE=$PIECE(VEVL,":",2)
IF VAL=$PIECE(VEVL,":",1)
SET VEQFL=1
End DoDot:1
IF VEQFL
QUIT
+11 ;
+12 QUIT VALUE
+13 ;
TMPFL(MODE,UID,DFN) ;EP - Open to 'R'ead, Open to 'W'rite, 'C'lose or 'D'elete
+1 ; temporary file designed for use when converting report text to RPC
+2 ; data strings. Note that UID and DFN are components of the file name.
+3 ;
+4 ; Input
+5 ; MODE(Required) - 'R'(Read),'W'(Write),'C'(Close),'D'(Delete)
+6 ; UID(Req'd for modes D,R,W) - Job identifier
+7 ; DFN(Req'd for modes D,R,W) - Patient IEN
+8 ; Output
+9 ; POP - 0 for success, 1 for failure
+10 ;
+11 NEW POP,HSPATH,HSFN
+12 SET POP=1
+13 ;
+14 ; To close a file.
+15 IF MODE="C"
DO CLOSE^%ZISH("AGGFILE")
+16 ;
+17 ; To Delete, Read-From, or Write-To a file.
+18 IF "D/R/W"[MODE
Begin DoDot:1
+19 SET HSPATH=$$DEFDIR^%ZISH("")
+20 IF HSPATH=""
SET HSPATH=$$PWD^%ZISH()
+21 SET HSFN=UID_"_"_$GET(DFN)_".DAT"
End DoDot:1
+22 ;
+23 ; To delete a file
+24 IF MODE="D"
SET POP=$$DEL^%ZISH(HSPATH,HSFN)
+25 ;
+26 ; To Read from or to Write to a file.
+27 IF (MODE="R")!(MODE="W")
Begin DoDot:1
+28 DO OPEN^%ZISH("AGGFILE",HSPATH,HSFN,MODE)
End DoDot:1
+29 QUIT POP
+30 ;
HRN(DFN) ;EP - Patient Health Record Number
+1 ;
+2 ;Description
+3 ; Returns the patient's health record number
+4 ;Input
+5 ; DFN - Patient internal entry number
+6 ; DUZ(2) - Assumes DUZ(2) exists since it's defined by
+7 ; signing on to the system as the user's default
+8 ; facility
+9 ;Output
+10 ; HRN - Health Record number for the user's default
+11 ; facility
+12 ;
+13 IF $GET(DUZ(2))=""
QUIT ""
+14 IF $GET(DFN)=""
QUIT ""
+15 ;
+16 NEW HRN
+17 SET HRN=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+18 IF $PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,3)'=""
SET HRN="*"_HRN
+19 QUIT HRN
+20 ;
HRNL(DFN,LOC) ;PEP - Patient's Health Record Number
+1 ; Input
+2 ; DFN - Patient's internal entry number
+3 ; LOC - Facility internal entry number (so does not depend on DUZ(2)
+4 ;
+5 IF $GET(LOC)=""
QUIT ""
+6 IF $GET(DFN)=""
QUIT ""
+7 NEW HRN
+8 SET HRN=$PIECE($GET(^AUPNPAT(DFN,41,LOC,0)),U,2)
+9 IF $PIECE($GET(^AUPNPAT(DFN,41,LOC,0)),U,3)'=""
SET HRN="*"_HRN
+10 QUIT HRN
+11 ;
SENS(DFN) ;EP - Is patient sensitive flag
+1 ;Input
+2 ; DFN - Patient internal entry number
+3 NEW FLAG
+4 SET FLAG=+$PIECE($GET(^DGSL(38.1,+DFN,0)),"^",2)
+5 SET FLAG=$SELECT(FLAG=1:"YES",1:"NO")
+6 QUIT FLAG
+7 ;
CTY(DFN) ;EP - Combines city,state and zip
+1 NEW ADATA,RESULT,STN,AZIP,LZIP
+2 SET ADATA=$GET(^DPT(DFN,.11))
IF ADATA=""
QUIT ""
+3 SET RESULT=$PIECE(ADATA,U,4)
+4 IF RESULT'=""
SET RESULT=RESULT_", "
+5 SET STN=$PIECE(ADATA,U,5)
+6 IF STN'=""
SET RESULT=RESULT_$PIECE(^DIC(5,STN,0),U,2)_" "
+7 SET AZIP=$PIECE(ADATA,U,6)
+8 SET LZIP=$PIECE(ADATA,U,12)
+9 SET RESULT=RESULT_$SELECT(LZIP'="":LZIP,1:AZIP)
+10 QUIT RESULT
+11 ;
CHS(DFN,PAIR) ;EP - CHS Eligibility
+1 NEW C0,RESULT
+2 SET C0=0
SET RESULT=""
+3 SET C0=$ORDER(^AUPNPAT(DFN,34,C0))
IF 'C0
QUIT RESULT
Begin DoDot:1
+4 IF $GET(PAIR)=1
SET RESULT=C0_$CHAR(28)_$PIECE($GET(^AUPNELM(C0,0)),U,1)
QUIT
+5 SET RESULT=$PIECE($GET(^AUPNELM(C0,0)),U,1)
End DoDot:1
+6 QUIT RESULT
+7 ;
ALT(DFN) ;EP - Alternate Resources
+1 NEW RESULT,AGINSN1,AGINS,AGCAT,ISACTIVE,AGGUAR,AGSEL,AOPCOINS
+2 NEW DATEINEF,FIXLIST,INSGEND,MEDCARE,NEWSEQR,PHREC,POLH,RAILROAD
+3 NEW REC,RELPOLHO,SPECSUB,TRUEPOLH,AGINSNN,PLANNAME,PLANPTR,MAX
+4 NEW GRPNUMB,COINS,ENTDAT,EFF,END
+5 DO EP^AGINS
+6 DO LOADCAT^AGCAT
+7 SET ISACTIVE=0
+8 SET N=0
+9 FOR
SET N=$ORDER(AGINS(N))
IF N=""
QUIT
Begin DoDot:1
+10 SET EFF=$PIECE(AGINS(N),U,5)
SET END=$PIECE(AGINS(N),U,6)
+11 IF $$ISACTIVE^AGINSUPD(EFF,END)
SET ISACTIVE=1
End DoDot:1
+12 IF 'ISACTIVE
SET RESULT="NO"
+13 IF ISACTIVE
SET RESULT="YES"
+14 QUIT RESULT
+15 ;
MREC(DFN) ;EP - Status of Medical Record
+1 NEW RESULT,VAL
+2 SET VAL=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,4)
+3 IF VAL=""
QUIT ""
+4 QUIT VAL_$CHAR(28)_$PIECE(^AUTTDIS(VAL,0),U,1)
+5 ;
AOB(DFN) ;EP - Assign of Benefits
+1 NEW RESULT,DATE
+2 SET DATE=""
+3 SET DATE=$ORDER(^AUPNPAT(DFN,71,"B",DATE),-1)
+4 IF 'DATE
QUIT ""
+5 QUIT $$FMTE^AGGUL1(DATE)
+6 ;
ROI(DFN) ;EP - Release of Information
+1 NEW RESULT,DATE
+2 SET DATE=""
+3 SET DATE=$ORDER(^AUPNPAT(DFN,36,"B",DATE),-1)
+4 IF 'DATE
QUIT ""
+5 QUIT $$FMTE^AGGUL1(DATE)
+6 ;
ADR(PATDFN,FORCE) ; EP - Update PREVIOUS MAIL ADDRESSES
+1 ; Copied and modified from AGUTILS
+2 SET FORCE=$GET(FORCE)
+3 ; Quit if they already have a historical address
+4 IF FORCE="F"
IF $ORDER(^AUPNPAT(PATDFN,83,0))
QUIT
+5 NEW ADDREC,DIE,DIC,DR,DA
+6 SET DA(1)=PATDFN
+7 SET DIC="^AUPNPAT("_DA(1)_",83,"
+8 SET DIC(0)="L"
+9 SET X=""""_DT_""""
+10 DO ^DIC
+11 IF Y<0
QUIT
+12 SET ADDREC=+Y
+13 ;
+14 ;get the current ADDRESS VALUES
+15 NEW AGSTR1,AGSTR2,AGSTR3,AGCITY,AGSTATE,AGZIP,AGHPHONE
+16 SET AGSTR1=$$GET1^DIQ(2,PATDFN_",",.111)
+17 SET AGSTR2=$$GET1^DIQ(2,PATDFN_",",.112)
+18 SET AGSTR3=$$GET1^DIQ(2,PATDFN_",",.113)
+19 SET AGCITY=$$GET1^DIQ(2,PATDFN_",",.114)
+20 SET AGSTATE=$$GET1^DIQ(2,PATDFN_",",.115)
+21 IF $GET(AGSTATE)'=""
IF AGSTATE'=+AGSTATE
SET AGSTATE=$ORDER(^DIC(5,"B",AGSTATE,""))
+22 SET AGZIP=$SELECT($$GET1^DIQ(2,PATDFN_",",.1112,"E")'="":$$GET1^DIQ(2,PATDFN_",",.1112,"E"),1:$$GET1^DIQ(2,PATDFN_",",.116))
+23 SET AGHPHONE=$$GET1^DIQ(2,PATDFN_",",.131)
+24 ;
+25 KILL DIE,DIC,DR,DA,DIR
+26 SET DA=ADDREC
SET DA(1)=PATDFN
SET IENS=$$IENS^DILF(.DA)
+27 SET DIE="^AUPNPAT("_DA(1)_",83,"
+28 IF FORCE="F"
Begin DoDot:1
+29 SET AGGUPD(9000001.83,IENS,.02)="AGSTR1"
SET AGGUPD(9000001.83,IENS,.03)="AGSTR2"
SET AGGUPD(9000001.83,IENS,.04)="AGSTR3"
+30 SET AGGUPD(9000001.83,IENS,.05)="AGCITY"
SET AGGUPD(9000001.83,IENS,.06)="AGSTATE"
SET AGGUPD(9000001.83,IENS,.07)="AGZIP"
+31 SET AGGUPD(9000001.83,IENS,.08)="AGHPHONE"
+32 ;S DR=".02////AGSTR1;.03////AGSTR2;.04////AGSTR3;.05////AGCITY;.06////AGSTATE;.07////AGZIP;.08////AGHPHONE"
End DoDot:1
+33 IF FORCE'="F"
Begin DoDot:1
+34 SET AGGUPD(9000001.83,IENS,.02)=AGSTR1
SET AGGUPD(9000001.83,IENS,.03)=AGSTR2
SET AGGUPD(9000001.83,IENS,.04)=AGSTR3
+35 SET AGGUPD(9000001.83,IENS,.05)=AGCITY
SET AGGUPD(9000001.83,IENS,.06)=AGSTATE
SET AGGUPD(9000001.83,IENS,.07)=AGZIP
+36 SET AGGUPD(9000001.83,IENS,.08)=AGHPHONE
+37 ;S DR=".02///^S X=AGSTR1;.03///^S X=AGSTR2;.04///^S X=AGSTR3;.05///^S X=AGCITY;.06///^S X=AGSTATE;.07///^S X=AGZIP;.08///^S X=AGHPHONE"
End DoDot:1
+38 DO FILE^DIE("","AGGUPD","ERROR")
+39 QUIT
+40 ;
EML(DFN) ; EP - Update PREVIOUS EMAIL ADDRESSES
+1 NEW ADDREC,DIE,DIC,DR,DA,AGEMAIL,AGGUPD,ERROR
+2 SET DA(1)=DFN
+3 SET DIC="^AUPNPAT("_DA(1)_",82,"
+4 SET DIC(0)="L"
+5 SET X=""""_DT_""""
+6 DO ^DIC
+7 IF Y<0
QUIT
+8 SET ADDREC=+Y
+9 SET AGEMAIL=$$GET1^DIQ(9000001,DFN_",",1802)
IF AGEMAIL=""
QUIT
+10 SET DA=ADDREC
SET DA(1)=DFN
SET IENS=$$IENS^DILF(.DA)
+11 SET AGGUPD(9000001.82,IENS,.02)=AGEMAIL
+12 DO FILE^DIE("","AGGUPD","ERROR")
+13 QUIT
+14 ;
TRIB(DFN) ; EP - Get list of other tribes
+1 NEW RESULT,DA,IENS
+2 SET RESULT=""
+3 SET DA(1)=DFN
SET DA=0
+4 FOR
SET DA=$ORDER(^AUPNPAT(DFN,43,DA))
IF 'DA
QUIT
Begin DoDot:1
+5 SET IENS=$$IENS^DILF(.DA)
+6 SET RESULT=RESULT_$$GET1^DIQ(9000001.43,IENS,.01,"E")_";"
End DoDot:1
+7 SET RESULT=$$TKO^AGGUL1(RESULT,";")
+8 IF RESULT=""
SET RESULT="NONE LISTED"
+9 QUIT RESULT
