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