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

VAFCPTED.m

Go to the documentation of this file.
  1. VAFCPTED ;ISA/RJS,Zoltan-EDIT EXISTING PATIENT ;4/15/22 16:30
  1. ;;5.3;Registration;**149,333,756,837,974,1059,1071**;Aug 13, 1993;Build 4
  1. ;
  1. EDIT(DGDFN,ARRAY,STRNGDR) ;-- Edits existing patient
  1. ;Input:
  1. ; DGDFN - IEN in the PATIENT (#2) file
  1. ; ARRAY - Array containing fields to be edited.
  1. ; Ex. ARRAY(.111)="123 STREET" or ARRAY(2,.111)="123...
  1. ; STRNGDR - String of delimited PATIENT (#2) file fields in the order
  1. ; in which the fields will be processed by DIE.
  1. ; Ex. ".01;.03;.05..."
  1. ;Output:
  1. ; No output
  1. ;
  1. S U="^"
  1. N LOCKFLE,FLD,ZTQUEUED,DIQUIET,VAFCX,STRNG
  1. S (ZTQUEUED,DIQUIET)=1
  1. L +^DPT(DGDFN):60
  1. S LOCKFLE=$T ; Need to remember whether the lock went through.
  1. ;process the given PATIENT file DR string in the given order
  1. S STRNG=STRNGDR F VAFCX=1:1 Q:STRNG="" S FLD=$P(STRNGDR,";",VAFCX) S STRNG=$P(STRNGDR,";",VAFCX+1,$L(STRNGDR,";")) D LOAD
  1. ;
  1. ;Do Address Bulletin if incoming Address does not equal existing
  1. ;Address - removed bulletin with patch DG*5.3*333
  1. ;I $D(@ARRAY@(.111))!$D(@ARRAY@(.112))!$D(@ARRAY@(.113))!$D(@ARRAY@(.114))!$D(@ARRAY@(.115))!$D(@ARRAY@(.117))!$D(@ARRAY@(.1112)) D
  1. ;. D ADDRESS^RGRSBULL(DGDFN,$G(@ARRAY@(.01)),$G(@ARRAY@(.111)),$G(@ARRAY@(.112)),$G(@ARRAY@(.113)),@ARRAY@("SENDING SITE"),$G(@ARRAY@(.114)),$G(@ARRAY@(.117)),$G(@ARRAY@(.115)),$G(@ARRAY@(.1112)))
  1. ;
  1. I LOCKFLE L -^DPT(DGDFN)
  1. ;
  1. K DIE,DA
  1. Q
  1. ;
  1. LOAD ; -- Loads fields to patient file
  1. N DR,DIE
  1. ;**756 check if updating ALIAS
  1. I FLD=1 D Q
  1. . ;**974,Story 841921 (mko): If flag is not set, compare and update the Alias .01;
  1. . ; If the flag is set, compare and update the Alias Name Components
  1. . I '$$GETFLAG D ALIAS Q
  1. . D ALIASNC(ARRAY,DGDFN,.RGER)
  1. ;**974,Story 841921 (mko): File name components
  1. I FLD=1.01 D Q
  1. . N NAME
  1. . M NAME=@ARRAY@(1.01)
  1. . D UPDNC(DGDFN,.NAME)
  1. I FLD=.025 D UPDSEXOR(ARRAY,DGDFN,.RGER) Q ;**1059, VAMPI-11114 (dri) file sexual orientation
  1. I FLD=.2406 D UPDPRON(ARRAY,DGDFN,.RGER) Q ;**1059, VAMPI-11118 (dri) file pronoun
  1. S DA=DGDFN,DIE="^DPT("
  1. I $G(@ARRAY@(FLD))="" Q
  1. I $G(@ARRAY@(FLD))["@" S @ARRAY@(FLD)="@"
  1. I $G(@ARRAY@(FLD))[U Q
  1. S DR=FLD_"///^S X=$G(@ARRAY@(FLD))"
  1. D ^DIE
  1. Q
  1. ;
  1. UPDNC(DGDFN,NAME) ;
  1. N FDA,IEN,MSG,DIERR
  1. ;Call updater to add or edit entry in Name Component file
  1. S FDA(20,"?+1,",.01)=2
  1. S FDA(20,"?+1,",.02)=.01
  1. S FDA(20,"?+1,",.03)=DGDFN_","
  1. S:$D(NAME("FAMILY"))#2 FDA(20,"?+1,",1)=NAME("FAMILY")
  1. S:$D(NAME("GIVEN"))#2 FDA(20,"?+1,",2)=NAME("GIVEN")
  1. S:$D(NAME("MIDDLE"))#2 FDA(20,"?+1,",3)=NAME("MIDDLE")
  1. S:$D(NAME("SUFFIX"))#2 FDA(20,"?+1,",5)=NAME("SUFFIX")
  1. D UPDATE^DIE("K","FDA","IEN","MSG")
  1. Q
  1. ;
  1. ALIAS ;update Alias multiple **756
  1. ;allow the synchronizing of the Alias multiple with the data passed in the array
  1. ;array(1,x)=name (last, first middle suffix format)^ssn
  1. N HAVE,I,MIEN,ADD,DONE,FDA,MPIFERR,DEL,ALIAS,CNT,DGALIAS
  1. M HAVE=^DPT(DGDFN,.01)
  1. S CNT=0
  1. ;see if any need to be added
  1. S I=0 F S I=$O(@ARRAY@(1,I)) Q:'I D ;loop through incoming data
  1. .S ADD=1,(DONE,MIEN)=0 F S MIEN=$O(HAVE(MIEN)) Q:'MIEN D I DONE Q ;loop through existing data
  1. ..I $P(@ARRAY@(1,I),"^",1,2)=$P($G(HAVE(MIEN,0)),"^",1,2) S ADD=0,DONE=1 Q ;compare to existing data to see if already in subfile, if not then
  1. .I ADD S ALIAS=@ARRAY@(1,I) D ;add new entry to subfile
  1. ..S FDA(2.01,"+"_I_","_DGDFN_",",.01)=$P(@ARRAY@(1,I),"^")
  1. ..S FDA(2.01,"+"_I_","_DGDFN_",",1)=$P(@ARRAY@(1,I),"^",2)
  1. I $D(FDA) D UPDATE^DIE("E","FDA",,"MPIFERR") I $G(MPIFERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_MPIFERR("DIERR",1,"TEXT",1)
  1. ;delete entries
  1. K FDA,MPIFERR
  1. S MIEN=0 F S MIEN=$O(HAVE(MIEN)) Q:'MIEN D ;loop through existing data
  1. . ; **837,MVI_805 check for duplicates (name + ssn combination)
  1. . S HAVE=$P($G(HAVE(MIEN,0)),"^",1,2)
  1. . X $S(HAVE="":"",$D(DGALIAS(HAVE)):"S FDA(2.01,MIEN_"",""_DGDFN_"","",.01)=""@"" Q",1:"S DGALIAS(HAVE)=HAVE")
  1. . ;
  1. . S DEL=1,(DONE,I)=0 F S I=$O(@ARRAY@(1,I)) Q:'I D I DONE Q ;loop through incoming data
  1. . . I HAVE=$P(@ARRAY@(1,I),"^",1,2) S DEL=0,DONE=1 Q ;compare to existing data to see if data should be deleted
  1. . I DEL S FDA(2.01,MIEN_","_DGDFN_",",.01)="@" ;existing entry to delete
  1. I $D(FDA) D FILE^DIE("E","FDA","MPIERR") I $G(MPIFERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_MPIFERR("DIERR",1,"TEXT",1) ;delete entry
  1. Q
  1. ;
  1. ALIASNC(ARRAY,DGDFN,RGER) ;Compare incoming Alias Name Components with existing Alias Name Components and add or delete as necessary
  1. ;**974,Story 841921 (mko): New subroutine
  1. N FDA,HAVE,IEN,IENROOT,IN,NC,NCIEN,NCIENS,ORIG,SEQ,SUB
  1. ;
  1. ;Create IN("surname^firstname^middlename^suffix^ssn",seq#)="" from incoming data
  1. S SEQ=0 F S SEQ=$O(@ARRAY@(1,SEQ)) Q:'SEQ D
  1. . S IN(@ARRAY@(1,SEQ,"NC")_"^"_$P(@ARRAY@(1,SEQ),"^",2),SEQ)=""
  1. ;
  1. ;Create ORIG("surname^firstname^middlename^suffix^ssn",subien)="" from existing data
  1. M HAVE=^DPT(DGDFN,.01)
  1. S IEN=0 F S IEN=$O(HAVE(IEN)) Q:'IEN D
  1. . S NCIEN=$P(HAVE(IEN,0),"^",3)
  1. . D:$P(HAVE(IEN,0),"^",3)>0
  1. .. S NC=$G(^VA(20,NCIEN,1))
  1. .. S SUB=$P(NC,"^",1,3)_"^"_$P(NC,"^",5)_"^"_$P(HAVE(IEN,0),"^",2)
  1. .. ;If this is a duplicate, set the FDA for deletion here
  1. .. S:$D(ORIG(SUB)) FDA(2.01,IEN_","_DGDFN_",",.01)="@"
  1. .. S ORIG(SUB,IEN)=""
  1. ;
  1. ;Loop through ORIG to delete Aliases that aren't in IN array
  1. S SUB="" F S SUB=$O(ORIG(SUB)) Q:SUB="" D
  1. . D:'$D(IN(SUB))
  1. .. S IEN=$O(ORIG(SUB,0)) Q:'IEN
  1. .. S FDA(2.01,IEN_","_DGDFN_",",.01)="@"
  1. D:$D(FDA)
  1. . D FILE^DIE("E","FDA","MSG") K FDA
  1. . I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG
  1. ;
  1. ;Loop through IN and add Aliases that aren't in ORIG array; we need to add the Alias, before the Name Components entry can be updated
  1. S SUB="" F S SUB=$O(IN(SUB)) Q:SUB="" D
  1. . D:'$D(ORIG(SUB))
  1. .. S SEQ=$O(IN(SUB,0))
  1. .. S FDA(2.01,"+"_SEQ_","_DGDFN_",",.01)=$$FMTNAME(@ARRAY@(1,SEQ,"NC"))
  1. .. S FDA(2.01,"+"_SEQ_","_DGDFN_",",1)=$P(@ARRAY@(1,SEQ),"^",2)
  1. D:$D(FDA)
  1. . ;Add the Alias and Alias SSN
  1. . D UPDATE^DIE("E","FDA","IENROOT","MSG") K FDA
  1. . I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG
  1. . ;For each Alias added, update the corresponding Name Components entry
  1. . S SEQ=0 F S SEQ=$O(IENROOT(SEQ)) Q:'SEQ D
  1. .. S IEN=$G(IENROOT(SEQ)) Q:IEN'>0
  1. .. S NCIENS=$P($G(^DPT(DGDFN,.01,IEN,0)),"^",3)_"," Q:'NCIENS
  1. .. S NC=$G(@ARRAY@(1,SEQ,"NC"))
  1. .. S FDA(20,NCIENS,1)=$P(NC,"^")
  1. .. S FDA(20,NCIENS,2)=$P(NC,"^",2)
  1. .. S FDA(20,NCIENS,3)=$P(NC,"^",3)
  1. .. S FDA(20,NCIENS,5)=$P(NC,"^",4)
  1. .. D FILE^DIE("E","FDA","MSG") K FDA
  1. .. I $G(DIERR) S RGER="-1^"_$$BLDERR("MSG") K MSG
  1. Q
  1. ;
  1. BLDERR(MSGROOT) ;Build an error from the error message array
  1. ;**974,Story 841921 (mko): New subroutine
  1. N ERRARR,ERRMSG,I
  1. D MSG^DIALOG("AE",.ERRARR,"","",MSGROOT)
  1. S ERRMSG="",I=0 F S I=$O(ERRARR(I)) Q:'I S ERRMSG=ERRMSG_$S(ERRMSG]"":" ",1:"")_$G(ERRARR(I))
  1. Q ERRMSG
  1. ;
  1. FMTNAME(ARRAY,LEN) ;Return a formatted name from cleaned Name Components that doesn't exceed LEN characters in length.
  1. ;**974,Story 841921 (mko): New function (duplicate of FMTNAME^RGADTP3)
  1. N NC
  1. S:'$G(LEN) LEN=30
  1. ;
  1. ;If ARRAY is passed as a string and doesn't have descendants assume it equals "surname^first^middle^suffix"
  1. D:$D(ARRAY)=1
  1. . S ARRAY("SURNAME")=$P(ARRAY,"^")
  1. . S ARRAY("FIRST")=$P(ARRAY,"^",2)
  1. . S ARRAY("MIDDLE")=$P(ARRAY,"^",3)
  1. . S ARRAY("SUFFIX")=$P(ARRAY,"^",4)
  1. ;
  1. ;Clean the components
  1. S NC("FAMILY")=$$CLEANC^XLFNAME($G(ARRAY("SURNAME")))
  1. S NC("GIVEN")=$$CLEANC^XLFNAME($G(ARRAY("FIRST")))
  1. S NC("MIDDLE")=$$CLEANC^XLFNAME($G(ARRAY("MIDDLE")))
  1. S NC("SUFFIX")=$$CLEANC^XLFNAME($G(ARRAY("SUFFIX")))
  1. ;
  1. ;Build a full name, maximum length LEN
  1. Q $$NAMEFMT^XLFNAME(.NC,"F","CL"_LEN)
  1. ;
  1. GETFLAG() ;Get the value of the name components flag
  1. ;**974,Story 841921 (mko): New function
  1. I $T(GETFLAG^MPIFNAMC)]"" Q $$GETFLAG^MPIFNAMC
  1. Q 0
  1. ;
  1. UPDSEXOR(ARRAY,DGDFN,RGER) ;**1059, VAMPI-11114 (dri) compare incoming sexual orientation multiple with existing and add/update
  1. ;**1071 VAMPI-13755 (dri) - include status, date created, date last updated to compare and file
  1. ; Input:
  1. ; ARRAY = ARAY(2)
  1. ; ARAY(2,.025,n) = sexual orientation code ^ status ^ date created ^ date last update
  1. ; DGDFN = patient's dfn
  1. ;
  1. ; Example:
  1. ; ARAY(2,.025,1)="CND^I^3220128^3220128"
  1. ; ARAY(2,.025,2)="DTK^E^3220128^3220128"
  1. ; ARAY(2,.025,3)="OTH^A^3220128^3220128"
  1. ;
  1. N CUR,FDA,I,INC,SOCODE,SOIEN,VAFCERR
  1. I $G(@ARRAY@(.025,1))["@" S @ARRAY@(.025,1)="@" ;change "@" to @, since no so's received in obx's delete all so's at the vista
  1. I $G(@ARRAY@(.025,1))'="@" S I=0 F S I=$O(@ARRAY@(.025,I)) Q:'I S SOCODE=$P($G(@ARRAY@(.025,I)),"^",1) I SOCODE'="",(SOCODE'["@"),(SOCODE'="""""") S INC(SOCODE)=I ;incoming so's
  1. S I=0 F S I=$O(^DPT(DGDFN,.025,I)) Q:'I S SOIEN=+$P($G(^(I,0)),"^",1),SOCODE=$P($G(^DG(47.77,SOIEN,0)),"^",2) I SOCODE'="" S CUR(SOCODE)=I ;current so's at vista
  1. ;
  1. ;loop through incoming sexual orientations and add/update
  1. S SOCODE="" F S SOCODE=$O(INC(SOCODE)) Q:SOCODE="" D
  1. .I '$D(CUR(SOCODE)) D Q ;an add to vista
  1. ..F I=1:1:4 S FDA(2.025,"+"_INC(SOCODE)_","_DGDFN_",",I*.01)=$P($G(@ARRAY@(.025,INC(SOCODE))),"^",I)
  1. ..S FDA(2.025,"+"_INC(SOCODE)_","_DGDFN_",",.06)="R" ;since this entry is new to vista and via hl7 it came from somewhere else, type of update is 'R'emote
  1. .;
  1. .I $D(CUR(SOCODE)) D ;an update to vista if something changed
  1. ..F I=2:1:4 I $P($G(@ARRAY@(.025,INC(SOCODE))),"^",I)'=$P($G(^DPT(DGDFN,.025,CUR(SOCODE),0)),"^",I) D
  1. ...S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",I*.01)=$P($G(@ARRAY@(.025,INC(SOCODE))),"^",I)
  1. ...;S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",.05)="@"
  1. ...S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",.06)="R" ;since this entry is being modified via hl7 it came from somewhere else, note is deleted and type of update is 'R'emote
  1. ;
  1. ;loop through vista and delete if not in incoming so's
  1. S SOCODE="" F S SOCODE=$O(CUR(SOCODE)) Q:SOCODE="" I '$D(INC(SOCODE)) S FDA(2.025,CUR(SOCODE)_","_DGDFN_",",.01)="@"
  1. ;
  1. I $D(FDA) D UPDATE^DIE("E","FDA",,"VAFCERR") I $G(VAFCERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_VAFCERR("DIERR",1,"TEXT",1)
  1. Q
  1. ;
  1. UPDPRON(ARRAY,DGDFN,RGER) ;**1059, VAMPI-11118 (dri) compare incoming pronoun multiple with existing and add/update
  1. ; Input:
  1. ; ARRAY = ARAY(2)
  1. ; ARAY(2,.2406,n) = pronoun code
  1. ; DGDFN = patient's dfn
  1. ;
  1. ; Example:
  1. ; ARAY(2,.2406,1)="OTH"
  1. ; ARAY(2,.2406,2)="PTN"
  1. ;
  1. N CUR,FDA,I,INC,PRCODE,PRIEN,VAFCERR
  1. I $G(@ARRAY@(.2406,1))["@" S @ARRAY@(.2406,1)="@" ;change "@" to @, since no pronouns received in obx's delete all pronouns at the vista
  1. I $G(@ARRAY@(.2406,1))'="@" S I=0 F S I=$O(@ARRAY@(.2406,I)) Q:'I S PRCODE=$P($G(@ARRAY@(.2406,I)),"^",1) I PRCODE'="",(PRCODE'["@"),(PRCODE'="""""") S INC(PRCODE)=I ;incoming pronouns
  1. S I=0 F S I=$O(^DPT(DGDFN,.2406,I)) Q:'I S PRIEN=+$P($G(^(I,0)),"^",1),PRCODE=$P($G(^DG(47.78,PRIEN,0)),"^",2) I PRCODE'="" S CUR(PRCODE)=I ;current pronouns at vista
  1. ;
  1. ;loop through incoming pronoun's and add if not in vista
  1. S PRCODE="" F S PRCODE=$O(INC(PRCODE)) Q:PRCODE="" I '$D(CUR(PRCODE)) S FDA(2.2406,"+"_INC(PRCODE)_","_DGDFN_",",.01)=PRCODE
  1. ;
  1. ;loop through vista and delete if not in incoming pronouns
  1. S PRCODE="" F S PRCODE=$O(CUR(PRCODE)) Q:PRCODE="" I '$D(INC(PRCODE)) S FDA(2.2406,CUR(PRCODE)_","_DGDFN_",",.01)="@"
  1. ;
  1. I $D(FDA) D UPDATE^DIE("E","FDA",,"VAFCERR") I $G(VAFCERR("DIERR",1,"TEXT",1))'="" S RGER="-1^"_VAFCERR("DIERR",1,"TEXT",1)
  1. Q
  1. ;