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

AGAPIPAT.m

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