AGAPIPAT ;IHS/DEPM/DMJ/TPF - PATIENT FILE(S) API'S [ 09/21/2006 5:24 PM ]
;;7.1;PATIENT REGISTRATION;**2,9,11**;AUG 25, 2005;Build 1
;INITIAL SUBROUTINE STUBS WERE WRITTEN BY DON JACKSON AT REQUEST OF JEANETTE
;KOMPKOFF. ON 9/28/2006 SANDRA LAHI REASSIGNED THE API TO TIM FRAZIER
;
;10/11/2006
;CALLS FROM DON WERE CHANGED FROM /// DIE CALLS TO DBS (API) CALLS TO
;ELIMINATE ALL POSSIBLE INTERACTIVE OUTPUT FROM THE API
;
;08/20/2010 - AG*7.1*9 - Added PREF/
;DISCUSSION IN SAC ON:
;TO LIMIT THE CALLER TO CERTAIN PACKAGES USE A REQUIRED PARAMETER OR $ZU(96,9)
;TO GET THE NAME OF THE CALLING ROUTINE??
;
;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
;
;EACH EDIT SUBROUTINE RETURNS 1 IF THE EDIT WAS SUCCESSFUL - $D(AGERRS) WILL BE 0
;OR A 0 IF UNSUCCESSFUL.
;IF THE CALL IS TRYING TO DELETE THE FIELD AND THE FIELD IS SET UP IN THE
;'REGISTRATION PARAMETER' FILE AS A REQUIRED FIELD FOR THE SITE THEN A MESSAGE
;WILL BE RETURNED.
;THE CALLER CAN PASS AN .ARRAY TO AGERRS TO RECEIVE ERROR MESSAGES IF ANY. THE
;ERROR MESSAGE ARRAY WILL BE CLEARED IMMEDIATELY UPON ENTRY TO THE API CALL
;
;
Q
F111(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .111 STREET ADDRESS [LINE 1]
;W !!,"CALLED BY: ",$ZU(96,9)
K AGERRS
;WHAT ARE CURRENT 'REGISTRATION PARAMETERS' #9009061 SETTINGS FOR SITE
;REQUIRED MANDATORY FIELDS
I $$ISREQ^AGFLDREQ(2,.111) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.111)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
F114(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .114 CITY
K AGERRS
I $$ISREQ^AGFLDREQ(2,.114) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.114)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
F115(AGDFN,AGVAL,AGERRS) ;EP -edit file 2, field .115 STATE
K AGERRS
I $$ISREQ^AGFLDREQ(2,.115) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.115)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
F116(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .116, ZIP CODE
K AGERRS
I $$ISREQ^AGFLDREQ(2,.116) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.116)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
F131(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .131 PHONE NUMBER [RESIDENCE]
K AGERRS
I $$ISREQ^AGFLDREQ(2,.131) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.131)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
F132(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .132 PHONE NUMBER [WORK]
K AGERRS
I $$ISREQ^AGFLDREQ(2,.132) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.132)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
F1219(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .1219 TEMPORARY PHONE NUMBER
K AGERRS
I $$ISREQ^AGFLDREQ(2,.1219) Q:($G(AGVAL)="@")!($G(AGVAL)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(2,AGIENS,.1219)=$G(AGVAL)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
NIH(AGDFN,AGNUM,AGERRS) ;EP - edit file 9000001 field .35 number in household
;NUM=number
K AGERRS
I $$ISREQ^AGFLDREQ(9000001,.35) Q:($G(AGNUM)="@")!($G(AGNUM)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=$G(AGDFN)_","
S AGFDA(9000001,AGIENS,.35)=$G(AGNUM)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
THI(AGDFN,AGAMT,AGERRS) ;EP - edit file 9000001, field .36 total household income
;AMT=amount
K AGERRS
I $$ISREQ^AGFLDREQ(9000001,.36) Q:($G(AGAMT)="@")!($G(AGAMT)="") "SITE MANDATORY FIELD REQUIRED"
N AGFDA,AGIENS
S AGIENS=AGDFN_","
S AGFDA(9000001,AGIENS,.36)=$G(AGAMT)
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
ARACE(AGDFN,AGRACE,AGMET,AGERRS) ;EP - add race
;AGRACE=race
;AGMET=method of collection file 10.3
K AGERRS
N AGFDA,AGIENS
S AGIENS="+1,"_$G(AGDFN)_","
S AGFDA(2.02,AGIENS,.01)=$G(AGRACE)
S AGFDA(2.02,AGIENS,.02)=$G(AGMET)
D UPDATE^DIE("E","AGFDA",,"AGERRS")
Q '$D(AGERRS)
;
;THE CALLER WILL NEED TO FIND OUT WHICH ENTRY IN THE MULTIPLE
;THEY WISH TO DELETE. THE AGDA IS THE IEN OF THE RACE IN THE 10.3 FILE
DRACE(AGDFN,AGDA,AGERRS) ;EP - delete race
K AGERRS
N AGFDA,AGIENS
S AGIENS=$G(AGDA)_","_$G(AGDFN)_","
S AGFDA(2.02,AGIENS,.01)="@"
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
AETH(AGDFN,AGETH,AGMET,AGERRS) ;EP - add ethnicity .06 In file 2
;AGETH=ethnicity SEE FILE 10.2
;AGMET=method of collection SEE FILE 10.3
K AGERRS
N AGFDA,AGIENS
S AGIENS="+1,"_$G(AGDFN)_","
S AGFDA(2.06,AGIENS,.01)=$G(AGETH)
S AGFDA(2.06,AGIENS,.02)=$G(AGMET)
D UPDATE^DIE("E","AGFDA",,"AGERRS")
Q '$D(AGERRS)
;
DETH(AGDFN,AGDA,AGERRS) ;EP - delete ethnicity
K AGERRS
Q:$G(AGDFN)="" "PARAMETER MISSING"
;there is only one entry allowed here even though its a mulitple
;if the caller does not supply the DA try and find it
S:$G(AGDA)="" AGDA=$O(^DPT(AGDFN,.06,0))
Q:AGDA="" "ENTRY NOT FOUND"
N AGFDA,AGIENS
S AGIENS=AGDA_","_AGDFN_","
S AGFDA(2.06,AGIENS,.01)="@"
D FILE^DIE("EK","AGFDA","AGERRS")
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
PREF(AGDFN,AGLNG,AGERRS) ;EP - edit file 9000001.86, field .04 PREFERRED LANGUAGE
;AG*7.1*9 - API Created
;Input:
; AGDFN - The Patient's IEN
; AGLNG - Preferred Language (pointer to 9999999.99)
;
;Output:
; Function Return - 1 (Success), 0 (Failure)
; AGERRS - Error message/array
;
N CHK,DA,IENS,AGLANG
K AGERRS
S:AGLNG="" AGLNG="@"
;
;Check to see if PREFERRED LANGUAGE field is required
I $$ALTREQ^AGFLDREQ(9000001,"PREFERRED LANGUAGE") I ($G(AGLNG)="@") S AGERRS="SITE MANDATORY FIELD REQUIRED" Q 0
;
;Check if Preferred Language not in the Primary or Other Spoken Language fields
S CHK=0 I AGLNG'="@" D
. N DEF,ERROR,IEN,LNG,OLNG,PRM
. S DEF=$$CLANG^AGED10B(AGDFN)
. S IEN=$P(DEF,U) ;IEN of Language multiple
. S PRM=$P($P(DEF,U,2),":") ;Primary Language
. I PRM=AGLNG S CHK=1 Q ;No Error if Primary equals Preferred
. ;
. ;Look in Other Languages
. D GETS^DIQ(9000001.86,IEN_","_AGDFN_",",".05*","I","OLNG","ERROR")
. S IEN="" F S IEN=$O(OLNG("9000001.8605",IEN)) Q:IEN="" D Q:CHK=1
.. S LNG=$G(OLNG("9000001.8605",IEN,".01","I")) Q:LNG=""
.. I LNG=AGLNG S CHK=1
;
;Log New Language Entry
S DA=$$NEWLG^AGED10B(AGDFN)
S DA(1)=AGDFN
S IENS=$$IENS^DILF(.DA)
I CHK=0,AGLNG'="@" S AGLANG(9000001.86,IENS,".02")=AGLNG ;Set primary if preferred not found
S AGLANG(9000001.86,IENS,".04")=AGLNG ;Preferred
D FILE^DIE("","AGLANG","AGERRS")
;
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
PMETH(AGDFN,AGMETH,AGERRS) ;EP - edit file 9000001 field 4002 PREFERRED REMINDER METHOD
;Input:
; AGDFN - The patient's IEN
; AGMETH - The patient's new Preferred Method of Communication ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
;
;Output:
; Function Return - 1 (Success), 0 (Failure)
; AGERRS - Error message/array
;
N AGFDA,AGIENS,%,%ANS,%D,%H,%I,EXTENT,FIELDNAM,RETURN,XBI
S:AGMETH="" AGMETH="@"
K AGERRS
;
;Entry Validation
;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
;I AGMETH'="P",AGMETH'="E",AGMETH'="M",AGMETH'="@" S AGERRS="INVALID ENTRY FOR FIELD. EXPECTING 'P', 'E', or 'M'" Q 0
I (AGMETH'="@")&($$EXTERNAL^DILFD(9000001,4002,,AGMETH)']"") S AGERRS="INVALID ENTRY FOR FIELD." Q 0
;
;Check to see if PREFERRED REMINDER METHOD field is required
I $$ISREQ^AGFLDREQ(9000001,4002) I ($G(AGMETH)="@")!($G(AGMETH)="") S AGERRS="SITE MANDATORY FIELD REQUIRED" Q 0
;
S AGIENS=$G(AGDFN)_","
S AGFDA(9000001,AGIENS,4002)=$G(AGMETH)
D FILE^DIE("EK","AGFDA","AGERRS")
;
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
EMAIL(AGDFN,AGEMAIL,AGUPDATE,AGERRS) ;EP - edit file 9000001 field 1802 CURRENT EMAIL ADDRESS
;Input:
; AGDFN - The Patient's IEN
; AGEMAIL - The patient's new email address
; AGUPDATE (Optional) - 0/Null - Add new email to historical email list, 1 - Do not add email to historical email list
;
;Output:
; Function Return - 1 (Success), 0 (Failure)
; AGERRS - Error message/array
;
N AGFDA,AGIENS,X,%,%ANS,%D,%H,%I,EXTENT,FIELDNAM,RETURN,XBI
S:AGEMAIL="" AGEMAIL="@"
S AGUPDATE=$G(AGUPDATE) S:AGUPDATE'=1 AGUPDATE=0
K AGERRS
;
;Entry Validation
I AGEMAIL'="@" S X=AGEMAIL D EMAIL^AUPNPED I '$D(X) S AGERRS="INVALID EMAIL ADDRESS FORMAT" Q 0
;
;Check to see if PREFERRED REMINDER METHOD field is required
I $$ISREQ^AGFLDREQ(9000001,1802) I ($G(AGEMAIL)="@")!($G(AGEMAIL)="") S AGERRS="SITE MANDATORY FIELD REQUIRED" Q 0
;
S AGIENS=$G(AGDFN)_","
S AGFDA(9000001,AGIENS,1802)=$G(AGEMAIL)
D FILE^DIE("EK","AGFDA","AGERRS")
;
;Save into History - Cannot use regular UPDTEMAL^AGUTILS call since it displays text to screen
I AGEMAIL'="@",'$D(AGERRS),'AGUPDATE D I $D(AGERRS) Q 0
. N ADDREC
. K DA,DIC,DIE,DIR,DR,X,Y
. S DA(1)=AGDFN
. S DIC="^AUPNPAT("_DA(1)_",82,"
. S DIC(0)="L"
. S X=""""_DT_""""
. D ^DIC
. I Y<0 S AGERRS="ERROR UPDATING HISTORICAL EMAIL ADDRESS" Q
. S ADDREC=+Y
. K DA,DIC,DIE,DR,X,Y
. S DA=ADDREC
. S DA(1)=AGDFN
. S DIE="^AUPNPAT("_DA(1)_",82,"
. S DR=".02///^S X=AGEMAIL;"
. D ^DIE
. K DA,DIC,DIE,DR,X,Y
;
I '$D(AGERRS) D UPDATE1^AGED(DUZ(2),AGDFN,1,"")
Q '$D(AGERRS)
;
;ALLOWED PACKAGES - not used yet
P ;;^SD^BSD^BW^WV^
AGAPIPAT ;IHS/DEPM/DMJ/TPF - PATIENT FILE(S) API'S [ 09/21/2006 5:24 PM ]
+1 ;;7.1;PATIENT REGISTRATION;**2,9,11**;AUG 25, 2005;Build 1
+2 ;INITIAL SUBROUTINE STUBS WERE WRITTEN BY DON JACKSON AT REQUEST OF JEANETTE
+3 ;KOMPKOFF. ON 9/28/2006 SANDRA LAHI REASSIGNED THE API TO TIM FRAZIER
+4 ;
+5 ;10/11/2006
+6 ;CALLS FROM DON WERE CHANGED FROM /// DIE CALLS TO DBS (API) CALLS TO
+7 ;ELIMINATE ALL POSSIBLE INTERACTIVE OUTPUT FROM THE API
+8 ;
+9 ;08/20/2010 - AG*7.1*9 - Added PREF/
+10 ;DISCUSSION IN SAC ON:
+11 ;TO LIMIT THE CALLER TO CERTAIN PACKAGES USE A REQUIRED PARAMETER OR $ZU(96,9)
+12 ;TO GET THE NAME OF THE CALLING ROUTINE??
+13 ;
+14 ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
+15 ;
+16 ;EACH EDIT SUBROUTINE RETURNS 1 IF THE EDIT WAS SUCCESSFUL - $D(AGERRS) WILL BE 0
+17 ;OR A 0 IF UNSUCCESSFUL.
+18 ;IF THE CALL IS TRYING TO DELETE THE FIELD AND THE FIELD IS SET UP IN THE
+19 ;'REGISTRATION PARAMETER' FILE AS A REQUIRED FIELD FOR THE SITE THEN A MESSAGE
+20 ;WILL BE RETURNED.
+21 ;THE CALLER CAN PASS AN .ARRAY TO AGERRS TO RECEIVE ERROR MESSAGES IF ANY. THE
+22 ;ERROR MESSAGE ARRAY WILL BE CLEARED IMMEDIATELY UPON ENTRY TO THE API CALL
+23 ;
+24 ;
+25 QUIT
F111(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .111 STREET ADDRESS [LINE 1]
+1 ;W !!,"CALLED BY: ",$ZU(96,9)
+2 KILL AGERRS
+3 ;WHAT ARE CURRENT 'REGISTRATION PARAMETERS' #9009061 SETTINGS FOR SITE
+4 ;REQUIRED MANDATORY FIELDS
+5 IF $$ISREQ^AGFLDREQ(2,.111)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+6 NEW AGFDA,AGIENS
+7 SET AGIENS=$GET(AGDFN)_","
+8 SET AGFDA(2,AGIENS,.111)=$GET(AGVAL)
+9 DO FILE^DIE("EK","AGFDA","AGERRS")
+10 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+11 QUIT '$DATA(AGERRS)
F114(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .114 CITY
+1 KILL AGERRS
+2 IF $$ISREQ^AGFLDREQ(2,.114)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+3 NEW AGFDA,AGIENS
+4 SET AGIENS=$GET(AGDFN)_","
+5 SET AGFDA(2,AGIENS,.114)=$GET(AGVAL)
+6 DO FILE^DIE("EK","AGFDA","AGERRS")
+7 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+8 QUIT '$DATA(AGERRS)
F115(AGDFN,AGVAL,AGERRS) ;EP -edit file 2, field .115 STATE
+1 KILL AGERRS
+2 IF $$ISREQ^AGFLDREQ(2,.115)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+3 NEW AGFDA,AGIENS
+4 SET AGIENS=$GET(AGDFN)_","
+5 SET AGFDA(2,AGIENS,.115)=$GET(AGVAL)
+6 DO FILE^DIE("EK","AGFDA","AGERRS")
+7 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+8 QUIT '$DATA(AGERRS)
+9 ;
F116(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .116, ZIP CODE
+1 KILL AGERRS
+2 IF $$ISREQ^AGFLDREQ(2,.116)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+3 NEW AGFDA,AGIENS
+4 SET AGIENS=$GET(AGDFN)_","
+5 SET AGFDA(2,AGIENS,.116)=$GET(AGVAL)
+6 DO FILE^DIE("EK","AGFDA","AGERRS")
+7 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+8 QUIT '$DATA(AGERRS)
+9 ;
F131(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .131 PHONE NUMBER [RESIDENCE]
+1 KILL AGERRS
+2 IF $$ISREQ^AGFLDREQ(2,.131)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+3 NEW AGFDA,AGIENS
+4 SET AGIENS=$GET(AGDFN)_","
+5 SET AGFDA(2,AGIENS,.131)=$GET(AGVAL)
+6 DO FILE^DIE("EK","AGFDA","AGERRS")
+7 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+8 QUIT '$DATA(AGERRS)
F132(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .132 PHONE NUMBER [WORK]
+1 KILL AGERRS
+2 IF $$ISREQ^AGFLDREQ(2,.132)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+3 NEW AGFDA,AGIENS
+4 SET AGIENS=$GET(AGDFN)_","
+5 SET AGFDA(2,AGIENS,.132)=$GET(AGVAL)
+6 DO FILE^DIE("EK","AGFDA","AGERRS")
+7 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+8 QUIT '$DATA(AGERRS)
F1219(AGDFN,AGVAL,AGERRS) ;EP - edit file 2, field .1219 TEMPORARY PHONE NUMBER
+1 KILL AGERRS
+2 IF $$ISREQ^AGFLDREQ(2,.1219)
IF ($GET(AGVAL)="@")!($GET(AGVAL)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+3 NEW AGFDA,AGIENS
+4 SET AGIENS=$GET(AGDFN)_","
+5 SET AGFDA(2,AGIENS,.1219)=$GET(AGVAL)
+6 DO FILE^DIE("EK","AGFDA","AGERRS")
+7 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+8 QUIT '$DATA(AGERRS)
NIH(AGDFN,AGNUM,AGERRS) ;EP - edit file 9000001 field .35 number in household
+1 ;NUM=number
+2 KILL AGERRS
+3 IF $$ISREQ^AGFLDREQ(9000001,.35)
IF ($GET(AGNUM)="@")!($GET(AGNUM)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+4 NEW AGFDA,AGIENS
+5 SET AGIENS=$GET(AGDFN)_","
+6 SET AGFDA(9000001,AGIENS,.35)=$GET(AGNUM)
+7 DO FILE^DIE("EK","AGFDA","AGERRS")
+8 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+9 QUIT '$DATA(AGERRS)
THI(AGDFN,AGAMT,AGERRS) ;EP - edit file 9000001, field .36 total household income
+1 ;AMT=amount
+2 KILL AGERRS
+3 IF $$ISREQ^AGFLDREQ(9000001,.36)
IF ($GET(AGAMT)="@")!($GET(AGAMT)="")
QUIT "SITE MANDATORY FIELD REQUIRED"
+4 NEW AGFDA,AGIENS
+5 SET AGIENS=AGDFN_","
+6 SET AGFDA(9000001,AGIENS,.36)=$GET(AGAMT)
+7 DO FILE^DIE("EK","AGFDA","AGERRS")
+8 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+9 QUIT '$DATA(AGERRS)
ARACE(AGDFN,AGRACE,AGMET,AGERRS) ;EP - add race
+1 ;AGRACE=race
+2 ;AGMET=method of collection file 10.3
+3 KILL AGERRS
+4 NEW AGFDA,AGIENS
+5 SET AGIENS="+1,"_$GET(AGDFN)_","
+6 SET AGFDA(2.02,AGIENS,.01)=$GET(AGRACE)
+7 SET AGFDA(2.02,AGIENS,.02)=$GET(AGMET)
+8 DO UPDATE^DIE("E","AGFDA",,"AGERRS")
+9 QUIT '$DATA(AGERRS)
+10 ;
+11 ;THE CALLER WILL NEED TO FIND OUT WHICH ENTRY IN THE MULTIPLE
+12 ;THEY WISH TO DELETE. THE AGDA IS THE IEN OF THE RACE IN THE 10.3 FILE
DRACE(AGDFN,AGDA,AGERRS) ;EP - delete race
+1 KILL AGERRS
+2 NEW AGFDA,AGIENS
+3 SET AGIENS=$GET(AGDA)_","_$GET(AGDFN)_","
+4 SET AGFDA(2.02,AGIENS,.01)="@"
+5 DO FILE^DIE("EK","AGFDA","AGERRS")
+6 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+7 QUIT '$DATA(AGERRS)
+8 ;
AETH(AGDFN,AGETH,AGMET,AGERRS) ;EP - add ethnicity .06 In file 2
+1 ;AGETH=ethnicity SEE FILE 10.2
+2 ;AGMET=method of collection SEE FILE 10.3
+3 KILL AGERRS
+4 NEW AGFDA,AGIENS
+5 SET AGIENS="+1,"_$GET(AGDFN)_","
+6 SET AGFDA(2.06,AGIENS,.01)=$GET(AGETH)
+7 SET AGFDA(2.06,AGIENS,.02)=$GET(AGMET)
+8 DO UPDATE^DIE("E","AGFDA",,"AGERRS")
+9 QUIT '$DATA(AGERRS)
+10 ;
DETH(AGDFN,AGDA,AGERRS) ;EP - delete ethnicity
+1 KILL AGERRS
+2 IF $GET(AGDFN)=""
QUIT "PARAMETER MISSING"
+3 ;there is only one entry allowed here even though its a mulitple
+4 ;if the caller does not supply the DA try and find it
+5 IF $GET(AGDA)=""
SET AGDA=$ORDER(^DPT(AGDFN,.06,0))
+6 IF AGDA=""
QUIT "ENTRY NOT FOUND"
+7 NEW AGFDA,AGIENS
+8 SET AGIENS=AGDA_","_AGDFN_","
+9 SET AGFDA(2.06,AGIENS,.01)="@"
+10 DO FILE^DIE("EK","AGFDA","AGERRS")
+11 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+12 QUIT '$DATA(AGERRS)
+13 ;
PREF(AGDFN,AGLNG,AGERRS) ;EP - edit file 9000001.86, field .04 PREFERRED LANGUAGE
+1 ;AG*7.1*9 - API Created
+2 ;Input:
+3 ; AGDFN - The Patient's IEN
+4 ; AGLNG - Preferred Language (pointer to 9999999.99)
+5 ;
+6 ;Output:
+7 ; Function Return - 1 (Success), 0 (Failure)
+8 ; AGERRS - Error message/array
+9 ;
+10 NEW CHK,DA,IENS,AGLANG
+11 KILL AGERRS
+12 IF AGLNG=""
SET AGLNG="@"
+13 ;
+14 ;Check to see if PREFERRED LANGUAGE field is required
+15 IF $$ALTREQ^AGFLDREQ(9000001,"PREFERRED LANGUAGE")
IF ($GET(AGLNG)="@")
SET AGERRS="SITE MANDATORY FIELD REQUIRED"
QUIT 0
+16 ;
+17 ;Check if Preferred Language not in the Primary or Other Spoken Language fields
+18 SET CHK=0
IF AGLNG'="@"
Begin DoDot:1
+19 NEW DEF,ERROR,IEN,LNG,OLNG,PRM
+20 SET DEF=$$CLANG^AGED10B(AGDFN)
+21 ;IEN of Language multiple
SET IEN=$PIECE(DEF,U)
+22 ;Primary Language
SET PRM=$PIECE($PIECE(DEF,U,2),":")
+23 ;No Error if Primary equals Preferred
IF PRM=AGLNG
SET CHK=1
QUIT
+24 ;
+25 ;Look in Other Languages
+26 DO GETS^DIQ(9000001.86,IEN_","_AGDFN_",",".05*","I","OLNG","ERROR")
+27 SET IEN=""
FOR
SET IEN=$ORDER(OLNG("9000001.8605",IEN))
IF IEN=""
QUIT
Begin DoDot:2
+28 SET LNG=$GET(OLNG("9000001.8605",IEN,".01","I"))
IF LNG=""
QUIT
+29 IF LNG=AGLNG
SET CHK=1
End DoDot:2
IF CHK=1
QUIT
End DoDot:1
+30 ;
+31 ;Log New Language Entry
+32 SET DA=$$NEWLG^AGED10B(AGDFN)
+33 SET DA(1)=AGDFN
+34 SET IENS=$$IENS^DILF(.DA)
+35 ;Set primary if preferred not found
IF CHK=0
IF AGLNG'="@"
SET AGLANG(9000001.86,IENS,".02")=AGLNG
+36 ;Preferred
SET AGLANG(9000001.86,IENS,".04")=AGLNG
+37 DO FILE^DIE("","AGLANG","AGERRS")
+38 ;
+39 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+40 QUIT '$DATA(AGERRS)
+41 ;
PMETH(AGDFN,AGMETH,AGERRS) ;EP - edit file 9000001 field 4002 PREFERRED REMINDER METHOD
+1 ;Input:
+2 ; AGDFN - The patient's IEN
+3 ; AGMETH - The patient's new Preferred Method of Communication ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
+4 ;
+5 ;Output:
+6 ; Function Return - 1 (Success), 0 (Failure)
+7 ; AGERRS - Error message/array
+8 ;
+9 NEW AGFDA,AGIENS,%,%ANS,%D,%H,%I,EXTENT,FIELDNAM,RETURN,XBI
+10 IF AGMETH=""
SET AGMETH="@"
+11 KILL AGERRS
+12 ;
+13 ;Entry Validation
+14 ;IHS/OIT/NKD AG*7.1*11 MU2 PREFERRED METHOD
+15 ;I AGMETH'="P",AGMETH'="E",AGMETH'="M",AGMETH'="@" S AGERRS="INVALID ENTRY FOR FIELD. EXPECTING 'P', 'E', or 'M'" Q 0
+16 IF (AGMETH'="@")&($$EXTERNAL^DILFD(9000001,4002,,AGMETH)']"")
SET AGERRS="INVALID ENTRY FOR FIELD."
QUIT 0
+17 ;
+18 ;Check to see if PREFERRED REMINDER METHOD field is required
+19 IF $$ISREQ^AGFLDREQ(9000001,4002)
IF ($GET(AGMETH)="@")!($GET(AGMETH)="")
SET AGERRS="SITE MANDATORY FIELD REQUIRED"
QUIT 0
+20 ;
+21 SET AGIENS=$GET(AGDFN)_","
+22 SET AGFDA(9000001,AGIENS,4002)=$GET(AGMETH)
+23 DO FILE^DIE("EK","AGFDA","AGERRS")
+24 ;
+25 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+26 QUIT '$DATA(AGERRS)
+27 ;
EMAIL(AGDFN,AGEMAIL,AGUPDATE,AGERRS) ;EP - edit file 9000001 field 1802 CURRENT EMAIL ADDRESS
+1 ;Input:
+2 ; AGDFN - The Patient's IEN
+3 ; AGEMAIL - The patient's new email address
+4 ; AGUPDATE (Optional) - 0/Null - Add new email to historical email list, 1 - Do not add email to historical email list
+5 ;
+6 ;Output:
+7 ; Function Return - 1 (Success), 0 (Failure)
+8 ; AGERRS - Error message/array
+9 ;
+10 NEW AGFDA,AGIENS,X,%,%ANS,%D,%H,%I,EXTENT,FIELDNAM,RETURN,XBI
+11 IF AGEMAIL=""
SET AGEMAIL="@"
+12 SET AGUPDATE=$GET(AGUPDATE)
IF AGUPDATE'=1
SET AGUPDATE=0
+13 KILL AGERRS
+14 ;
+15 ;Entry Validation
+16 IF AGEMAIL'="@"
SET X=AGEMAIL
DO EMAIL^AUPNPED
IF '$DATA(X)
SET AGERRS="INVALID EMAIL ADDRESS FORMAT"
QUIT 0
+17 ;
+18 ;Check to see if PREFERRED REMINDER METHOD field is required
+19 IF $$ISREQ^AGFLDREQ(9000001,1802)
IF ($GET(AGEMAIL)="@")!($GET(AGEMAIL)="")
SET AGERRS="SITE MANDATORY FIELD REQUIRED"
QUIT 0
+20 ;
+21 SET AGIENS=$GET(AGDFN)_","
+22 SET AGFDA(9000001,AGIENS,1802)=$GET(AGEMAIL)
+23 DO FILE^DIE("EK","AGFDA","AGERRS")
+24 ;
+25 ;Save into History - Cannot use regular UPDTEMAL^AGUTILS call since it displays text to screen
+26 IF AGEMAIL'="@"
IF '$DATA(AGERRS)
IF 'AGUPDATE
Begin DoDot:1
+27 NEW ADDREC
+28 KILL DA,DIC,DIE,DIR,DR,X,Y
+29 SET DA(1)=AGDFN
+30 SET DIC="^AUPNPAT("_DA(1)_",82,"
+31 SET DIC(0)="L"
+32 SET X=""""_DT_""""
+33 DO ^DIC
+34 IF Y<0
SET AGERRS="ERROR UPDATING HISTORICAL EMAIL ADDRESS"
QUIT
+35 SET ADDREC=+Y
+36 KILL DA,DIC,DIE,DR,X,Y
+37 SET DA=ADDREC
+38 SET DA(1)=AGDFN
+39 SET DIE="^AUPNPAT("_DA(1)_",82,"
+40 SET DR=".02///^S X=AGEMAIL;"
+41 DO ^DIE
+42 KILL DA,DIC,DIE,DR,X,Y
End DoDot:1
IF $DATA(AGERRS)
QUIT 0
+43 ;
+44 IF '$DATA(AGERRS)
DO UPDATE1^AGED(DUZ(2),AGDFN,1,"")
+45 QUIT '$DATA(AGERRS)
+46 ;
+47 ;ALLOWED PACKAGES - not used yet
P ;;^SD^BSD^BW^WV^
