VAFCAPI ;BIR/DRI - MVI API ENTRY POINTS ;5/18/22 09:21
;;5.3;Registration;**1071**;Aug 13, 1993;Build 4
;
;Supports IA #7323, Private subscription
;
;Reference to $$DT^XLFDT supported by IA# 10103
;Reference to ^TIU(8925 supported by IA#3376
;
SOGI(DFN,ARRAY,UPDATE) ;api for cprs to update sexual orientation and gender identity trait fields ;**1071, VAMPI-13755 (dri)
;
; Business Rules:
; ALL of a Patient's Sexual Orientations must be sent
; Once defined, Sexual Orientations can NOT be deleted, the status must be updated
; Sexual Orientation Date Created will default to today on an add
; Sexual Orientation Date Last Updated will default to today on an add or update
; Sexual Orientation Description added/updated when Sexual Orientation
; of 'Other' has a Status of 'A'ctive, otherwise it's deleted.
;
; When a TIU NOTE is passed to be deleted:
; If the site has received more recent sexual orientation updates the NOTE
; is deleted and no further updating of the sexual orientation data occures.
; If no recent sexual orientation updates have been received but previous
; updates exist then roll back to that data
;
;
;*To Add/Update a Patient's Sexual Orientation Data:
; DFN = pointer to entry in PATIENT (#2) file (required)
; ARRAY("SexOr",n) = sexual orientation code^status^note
; n - counter
; sexual orientation code - list of code(s) from the SEXUAL ORIENTATION TYPES (#47.77) file (required)
; status - current status of the sexual orientation (A/I) (required)
; note - note ien from the TIU DOCUMENT (#8925) file (optional)
; ARRAY("SexOrDes") = description for the selected 'Other' sexual orientation
; UPDATE = 1 to file data, else data is only validated (optional)
;
; Returns:
; 0 - if update is successful
; -1^error message - if unsuccessful
;
; Example:
; S DFN=100006920
; S ARRAY("SexOr",1)="BIS^I^5"
; S ARRAY("SexOr",2)="OTH^A"
; S ARRAY("SexOr",3)="STH^A"
; S ARRAY("SexOrDes")="SEXUAL ORIENTATION DESCRIPTION TEXT"
; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY) - to validate data
; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY,1) - to file data
;
;
;*To Delete a Patient's TIU NOTE:
; DFN = pointer to entry in PATIENT (#2) file (required)
; ARRAY("Note") = pointer to entry in TIU DOCUMENT (#8925) (required)
; UPDATE = 1 to file data, else data is only validated (optional)
;
; Returns:
; 0 - if update is successful
; -1^error message - if unsuccessful
;
; Example:
; S DFN=100006920
; S ARRAY("Note")=2
; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY) - to validate data
; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY,1) - to file data
;
;
I '$G(DFN) Q "-1^invalid DFN passed to api"
I '$D(^DPT(DFN,0)) Q "-1^entry does not exist in Patient file"
I $D(^DPT(DFN,-9)) Q "-1^merged patient"
;
I $G(UPDATE)'=1 S UPDATE=0 ;should data be filed
;
N TODAY
S TODAY=$$DT^XLFDT
;
I $G(ARRAY("Note")) Q $$NOTE(DFN,.ARRAY,UPDATE)
Q $$SEXOR(DFN,.ARRAY,UPDATE)
;
;
SEXOR(DFN,ARRAY,UPDATE) ;process incoming sexual orientation and sexual orientation description
N CD,CUR,ERROR,FDA,INC,NOTE,RES,SEQ,STATUS,VAFCERR
S ERROR=0
;
;loop through incoming sexual orientations, validate data, build list, ignore if passed with 'error' status
S SEQ=0 F S SEQ=$O(ARRAY("SexOr",SEQ)) Q:'SEQ I $P($G(ARRAY("SexOr",SEQ)),"^",2)'="E" D I ERROR Q
.S CD=$P($G(ARRAY("SexOr",SEQ)),"^",1) D CHK^DIE(2.025,.01,,CD,.RES,"VAFCERR") I RES="^" S ERROR="-1^"_$$BLDERR("VAFCERR") Q ;validate sexual orientation code
.S STATUS=$P($G(ARRAY("SexOr",SEQ)),"^",2) D CHK^DIE(2.025,.02,,STATUS,.RES,"VAFCERR") I RES="^" S ERROR="-1^"_$$BLDERR("VAFCERR") Q ;validate status
.S NOTE=$P($G(ARRAY("SexOr",SEQ)),"^",3) I NOTE'="",'$D(^TIU(8925,NOTE,0)) S ERROR="-1^Invalid TIU NOTE IEN" Q ;validate tiu note ien
.S INC(CD)=SEQ ;build incoming list
I ERROR Q ERROR
;
;validate sexual orientation description
I $G(ARRAY("SexOrDes"))'="" D
.D CHK^DIE(2,.0251,,ARRAY("SexOrDes"),.RES,"VAFCERR") I RES="^" S ERROR="-1^"_$$BLDERR("VAFCERR") Q
.I $S('$D(INC("OTH")):1,$P($G(ARRAY("SexOr",+$G(INC("OTH")))),"^",2)'="A":1,1:0) S ERROR="-1^Sexual Orientation of 'Other' with 'Active' Status required to update 'SO' Description"
I ERROR Q ERROR
;
;loop through current sexual orientations, validate data, build list
S SEQ=0 F S SEQ=$O(^DPT(DFN,.025,SEQ)) Q:'SEQ S CD=$$GET1^DIQ(47.77,+$P(^DPT(DFN,.025,SEQ,0),"^",1)_",",1) I CD'="" D I ERROR Q
.I '$D(INC(CD)),$P($G(^DPT(DFN,.025,SEQ,0)),"^",2)'="E" S ERROR="-1^Patient currently has more Sexual Orientations defined, entire list must be passed" ;errored 'so' not passed
.S CUR(CD)=SEQ ;build current list, must included 'errored' so duplicates aren't built
I ERROR Q ERROR
;
;loop through incoming values
S CD="" F S CD=$O(INC(CD)) Q:CD="" D
.I '$D(CUR(CD)) D ;if not in current array set fda for an add
..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.01)=CD ;sexual orientation
..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.02)=$P(ARRAY("SexOr",INC(CD)),"^",2) ;status
..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.03)=TODAY ;date created
..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.04)=TODAY ;date last updated
..I $P(ARRAY("SexOr",INC(CD)),"^",3) S FDA(2.025,"+"_INC(CD)_","_DFN_",",.05)="`"_$P(ARRAY("SexOr",INC(CD)),"^",3) ;note
..S FDA(2.025,"+"_INC(CD)_","_DFN_",",.06)="L" ;type of update - 'l'ocal
.;
.I $D(CUR(CD)) D ;if in current array set fda for an update
..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",2)'=$P(ARRAY("SexOr",INC(CD)),"^",2) S FDA(2.025,CUR(CD)_","_DFN_",",.02)=$P(ARRAY("SexOr",INC(CD)),"^",2) ;status change
..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",3)="" S FDA(2.025,CUR(CD)_","_DFN_",",.03)=TODAY ;date created if null
..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",4)'=TODAY S FDA(2.025,CUR(CD)_","_DFN_",",.04)=TODAY ;date last updated always updated to today
..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",5)'=$P(ARRAY("SexOr",INC(CD)),"^",3) S FDA(2.025,CUR(CD)_","_DFN_",",.05)=$S($P(ARRAY("SexOr",INC(CD)),"^",3):"`"_$P(ARRAY("SexOr",INC(CD)),"^",3),1:"@") ;note
..I $P($G(^DPT(DFN,.025,CUR(CD),0)),"^",6)'="L" S FDA(2.025,CUR(CD)_","_DFN_",",.06)="L" ;type of update - 'l'ocal
;
;current business rules don't allow sexual orientation deletions for any reason
;loop through current values, if not in incoming array set FDA to delete
;S CD="" F S CD=$O(CUR(CD)) Q:CD="" I '$D(INC(CD)) S FDA(2.025,CUR(CD)_","_DFN_",",.01)="@"
;
;process sexual orientation description,set fda to add/update/delete
I '$D(INC("OTH")),$$GET1^DIQ(2,DFN_",",.0251)'="" S FDA(2,DFN_",",.0251)="@" ;delete a previously filed sexual orientation description if no 'so' of 'Other'
I $D(INC("OTH")) D
.I $P(ARRAY("SexOr",+INC("OTH")),"^",2)'="A",$$GET1^DIQ(2,DFN_",",.0251)'="" S FDA(2,DFN_",",.0251)="@" Q ;delete a previously filed sexual orientation description if status of incoming 'so' of 'Other' isn't active
.I $P(ARRAY("SexOr",+INC("OTH")),"^",2)="A",$G(ARRAY("SexOrDes"))'="",ARRAY("SexOrDes")'=$$GET1^DIQ(2,DFN_",",.0251) S FDA1(2,DFN_",",.0251)=ARRAY("SexOrDes") ;add/update sexual orientation description since 'so' of 'Other' is active
;
I UPDATE D I ERROR Q ERROR
.I $D(FDA) S ERROR=$$UPDATE(.FDA) I ERROR Q ;file sexual orientation data
.I $D(FDA1) S ERROR=$$UPDATE(.FDA1) ;file sexual orientation description separately so 'ahist' x-ref is properly built
;
Q ERROR
;
;
NOTE(DFN,ARRAY,UPDATE) ;tiu note deletion
N ERROR,FDA,FDA1,GLO,LDLUP,NOTE,PREV,SEQ,SEQL
S ERROR=0
;
S NOTE=ARRAY("Note")
;I '$D(^TIU(8925,NOTE,0)) S ERROR="-1^Invalid TIU NOTE IEN" Q ;validate tiu note ien - no need to validate, could have already been deleted before calling api
S SEQ=0 F S SEQ=$O(^DPT(DFN,.025,SEQ)) Q:'SEQ I $P($G(^DPT(DFN,.025,SEQ,0)),"^",5)=NOTE S FDA(2.025,SEQ_","_DFN_",",.05)="@",SEQL(SEQ)="" ;delete note from entries, keep list of modified sequences
S GLO="^DPT(DFN,.025,""AHIST"")" F S GLO=$Q(@GLO) Q:GLO="" Q:($QS(GLO,3)'="AHIST") I $P(@GLO,"^",1)=NOTE S LDLUP=$QS(GLO,4) ;find most recent (last) date last update in history x-ref with tiu note, 'so' could already have a newer tiu note
I '$D(FDA)&'$G(LDLUP) S ERROR="-1^TIU NOTE doesn't exist in Patient's Sexual Orientation History" Q ERROR
I UPDATE,$D(FDA) S ERROR=$$UPDATE(.FDA) I ERROR Q ;delete note, let fileman fire x-ref's
I UPDATE S GLO="^DPT(DFN,.025,""AHIST"")" F S GLO=$Q(@GLO) Q:GLO="" Q:($QS(GLO,3)'="AHIST") I $P(@GLO,"^",1)=NOTE K @GLO S SEQL($QS(GLO,6))="" ;delete orphaned x-ref with a tiu note, possibly missed due to 'so' already having newer note
;
I $G(LDLUP) D ;this is the last 'date last updated' history x-ref's removed
.I $O(^DPT(DFN,.025,"AHIST",LDLUP)) Q ;more recent history exists in x-ref so don't update anything, since all 'so's always updated, no need to look at just modified 'so's
.;
.I $O(^DPT(DFN,.025,"AHIST",LDLUP+1),-1) D ;previous history exists, possibly from another site on the same day
..S GLO="^DPT(DFN,.025,""AHIST"",0)" F S GLO=$Q(@GLO) Q:GLO="" Q:$QS(GLO,3)'="AHIST" Q:$QS(GLO,4)>LDLUP I $QS(GLO,6),$D(SEQL($QS(GLO,6))) D ;find most recent past history for modified 'so's
...S PREV($QS(GLO,6))=$QS(GLO,7)_"^"_$QS(GLO,8)_"^"_$QS(GLO,9)_"^"_$QS(GLO,4)_"^"_$P($G(@GLO),"^",1)_"^"_$QS(GLO,5)
...I $QS(GLO,7)=5 S PREV($QS(GLO,6),"SexOrDes")=$P($G(@GLO),"^",2) ;only set description if 'Other'
.;
.S SEQ=0 F S SEQ=$O(SEQL(SEQ)) Q:'SEQ D ;only loop through the modified sexual orientations
..I $D(PREV(SEQ)) D Q ;if previous updates exist, roll back to how it looked
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",1)'=$P(PREV(SEQ),"^",1) S FDA(2.025,SEQ_","_DFN_",",.01)=$P(PREV(SEQ),"^",1) ;sexual orientation
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",2)'=$P(PREV(SEQ),"^",2) S FDA(2.025,SEQ_","_DFN_",",.02)=$P(PREV(SEQ),"^",2) ;status
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",3)'=$P(PREV(SEQ),"^",3) S FDA(2.025,SEQ_","_DFN_",",.03)=$P(PREV(SEQ),"^",3) ;date created
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",4)'=$P(PREV(SEQ),"^",4) S FDA(2.025,SEQ_","_DFN_",",.04)=$P(PREV(SEQ),"^",4) ;date last updated
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",5)'=$P(PREV(SEQ),"^",5) S FDA(2.025,SEQ_","_DFN_",",.05)=$S($P(PREV(SEQ),"^",5):"`"_$P(PREV(SEQ),"^",5),1:"@") ;note
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",6)'=$P(PREV(SEQ),"^",6) S FDA(2.025,SEQ_","_DFN_",",.06)=$P(PREV(SEQ),"^",6) ;type of update
...I $P($G(^DPT(DFN,.025,SEQ,0)),"^",1)=5,$P($G(^DPT(DFN,.241)),"^",1)'=$P(PREV(SEQ,"SexOrDes"),"^",1) S FDA1(2,DFN_",",.0251)=$S($P(PREV(SEQ,"SexOrDes"),"^",1)'="":$P(PREV(SEQ,"SexOrDes"),"^",1),1:"@") ;update sexual orientation description
..;
..I '$D(PREV(SEQ)) D ;if previous updates did not exist then it was 'entered in error'
...S FDA(2.025,SEQ_","_DFN_",",.02)="E" ;status
...S FDA(2.025,SEQ_","_DFN_",",.04)=TODAY ;date last updated
...S FDA(2,DFN_",",.0251)="@" ;sexual orientation description (use fda instead of fda1 so it deletes prior to the fda1 from above filing)
.;
I UPDATE D I ERROR Q ERROR
.I $D(FDA) S ERROR=$$UPDATE(.FDA) I ERROR Q
.I $D(FDA1) S ERROR=$$UPDATE(.FDA1) ;file sexual orientation description separately so 'ahist' x-ref is properly built
;
Q ERROR
;
UPDATE(FDA) ;call update
N VAFCERR
I '$D(FDA) Q 0
D UPDATE^DIE("E","FDA",,"VAFCERR")
I $D(VAFCERR) Q "-1^"_$$BLDERR("VAFCERR")
Q 0
;
;
BLDERR(MSGROOT) ;build error from FileMan error message array
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
;
;
SETSO ;set logic for 'AHIST' x-ref of Sexual Orientation Multiple (#.025) in Patient (#2) file
I $S(X(2)="E":0,X(5)=""&(X1(5)'=""):0,1:1),X(1)'="",X(2)'="",X(3)'="",X(4)'="",X(6)'="" D ;only set history when 'so' has a 'non-errored' status or tiu note not being deleted
.S ^DPT(DA(1),.025,"AHIST",X(4),X(6),DA,X(1),X(2),X(3))=$S(X(6)="L":X(5),1:"") ;only local updates can have tiu notes
Q
;
KILLSO ;kill logic for 'AHIST' x-ref of Sexual Orientation Multiple (#.025) in Patient (#2) file
I $S(X(2)'=""&(X2(2)="E"):1,X(4)'=""&(X2(4)'="")&(X2(4)<X(4)):1,X(5)'=""&(X2(5)=""):1,1:0),X(1)'="",X(2)'="",X(3)'="",X(4)'="",X(6)'="" D ;only kill history if status going to 'error', DLUP is 'rolling back' or tiu note is being deleted
.;attempt to kill off both 'local' and 'remote' x-ref, sync from mpi will looklook like a 'remote' update
.K ^DPT(DA(1),.025,"AHIST",X(4),"L",DA,X(1),X(2),X(3)) ;kill 'local' x-ref
.I $S(X(5)'=""&(X2(5)=""):0,1:1) K ^DPT(DA(1),.025,"AHIST",X(4),"R",DA,X(1),X(2),X(3)) ;kill 'remote' x-ref except on tiu note deletion, only 'local' can set/have a tiu note
Q
;
SETSOD ;set logic for 'AHIST' x-ref of Sexual Orientation Description (#.0251) in Patient (#2) file
I X(1)'="" N XX,XXDA0,XXDA S XXDA=$O(^DPT(DA,.025,"B",5,0)) I XXDA,$P($G(^DPT(DA,.025,XXDA,0)),"^",2)="A" S XXDA0=^(0) D ;only active sexual orientation 'Other' can have a description
.F XX=1:1:6 S XX(XX)=$P(XXDA0,"^",XX)
.I XX(1)'="",XX(2)'="",XX(3)'="",XX(4)'="",XX(6)'="",$D(^DPT(DA,.025,"AHIST",XX(4),XX(6),XXDA,XX(1),XX(2),XX(3))) S $P(^(XX(3)),"^",2)=X(1)
Q
;
KILLSOD ;kill logic for 'AHIST' x-ref of Sexual Orientation Description (#.0251) in Patient (#2) file
N XX,XXDA0,XXDA S XXDA=$O(^DPT(DA,.025,"B",5,0)) I XXDA S XXDA0=$G(^DPT(DA,.025,XXDA,0)) D
.F XX=1:1:6 S XX(XX)=$P(XXDA0,"^",XX)
.I XX(1)'="",XX(2)'="",XX(3)'="",XX(4)'="",XX(6)'="",$D(^DPT(DA,.025,"AHIST",XX(4),XX(6),XXDA,XX(1),XX(2),XX(3))) S $P(^(XX(3)),"^",2)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCAPI 13613 printed Apr 09, 2024@21:38:53 Page 2
VAFCAPI ;BIR/DRI - MVI API ENTRY POINTS ;5/18/22 09:21
+1 ;;5.3;Registration;**1071**;Aug 13, 1993;Build 4
+2 ;
+3 ;Supports IA #7323, Private subscription
+4 ;
+5 ;Reference to $$DT^XLFDT supported by IA# 10103
+6 ;Reference to ^TIU(8925 supported by IA#3376
+7 ;
SOGI(DFN,ARRAY,UPDATE) ;api for cprs to update sexual orientation and gender identity trait fields ;**1071, VAMPI-13755 (dri)
+1 ;
+2 ; Business Rules:
+3 ; ALL of a Patient's Sexual Orientations must be sent
+4 ; Once defined, Sexual Orientations can NOT be deleted, the status must be updated
+5 ; Sexual Orientation Date Created will default to today on an add
+6 ; Sexual Orientation Date Last Updated will default to today on an add or update
+7 ; Sexual Orientation Description added/updated when Sexual Orientation
+8 ; of 'Other' has a Status of 'A'ctive, otherwise it's deleted.
+9 ;
+10 ; When a TIU NOTE is passed to be deleted:
+11 ; If the site has received more recent sexual orientation updates the NOTE
+12 ; is deleted and no further updating of the sexual orientation data occures.
+13 ; If no recent sexual orientation updates have been received but previous
+14 ; updates exist then roll back to that data
+15 ;
+16 ;
+17 ;*To Add/Update a Patient's Sexual Orientation Data:
+18 ; DFN = pointer to entry in PATIENT (#2) file (required)
+19 ; ARRAY("SexOr",n) = sexual orientation code^status^note
+20 ; n - counter
+21 ; sexual orientation code - list of code(s) from the SEXUAL ORIENTATION TYPES (#47.77) file (required)
+22 ; status - current status of the sexual orientation (A/I) (required)
+23 ; note - note ien from the TIU DOCUMENT (#8925) file (optional)
+24 ; ARRAY("SexOrDes") = description for the selected 'Other' sexual orientation
+25 ; UPDATE = 1 to file data, else data is only validated (optional)
+26 ;
+27 ; Returns:
+28 ; 0 - if update is successful
+29 ; -1^error message - if unsuccessful
+30 ;
+31 ; Example:
+32 ; S DFN=100006920
+33 ; S ARRAY("SexOr",1)="BIS^I^5"
+34 ; S ARRAY("SexOr",2)="OTH^A"
+35 ; S ARRAY("SexOr",3)="STH^A"
+36 ; S ARRAY("SexOrDes")="SEXUAL ORIENTATION DESCRIPTION TEXT"
+37 ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY) - to validate data
+38 ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY,1) - to file data
+39 ;
+40 ;
+41 ;*To Delete a Patient's TIU NOTE:
+42 ; DFN = pointer to entry in PATIENT (#2) file (required)
+43 ; ARRAY("Note") = pointer to entry in TIU DOCUMENT (#8925) (required)
+44 ; UPDATE = 1 to file data, else data is only validated (optional)
+45 ;
+46 ; Returns:
+47 ; 0 - if update is successful
+48 ; -1^error message - if unsuccessful
+49 ;
+50 ; Example:
+51 ; S DFN=100006920
+52 ; S ARRAY("Note")=2
+53 ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY) - to validate data
+54 ; S RET=$$SOGI^VAFCAPI(DFN,.ARRAY,1) - to file data
+55 ;
+56 ;
+57 IF '$GET(DFN)
QUIT "-1^invalid DFN passed to api"
+58 IF '$DATA(^DPT(DFN,0))
QUIT "-1^entry does not exist in Patient file"
+59 IF $DATA(^DPT(DFN,-9))
QUIT "-1^merged patient"
+60 ;
+61 ;should data be filed
IF $GET(UPDATE)'=1
SET UPDATE=0
+62 ;
+63 NEW TODAY
+64 SET TODAY=$$DT^XLFDT
+65 ;
+66 IF $GET(ARRAY("Note"))
QUIT $$NOTE(DFN,.ARRAY,UPDATE)
+67 QUIT $$SEXOR(DFN,.ARRAY,UPDATE)
+68 ;
+69 ;
SEXOR(DFN,ARRAY,UPDATE) ;process incoming sexual orientation and sexual orientation description
+1 NEW CD,CUR,ERROR,FDA,INC,NOTE,RES,SEQ,STATUS,VAFCERR
+2 SET ERROR=0
+3 ;
+4 ;loop through incoming sexual orientations, validate data, build list, ignore if passed with 'error' status
+5 SET SEQ=0
FOR
SET SEQ=$ORDER(ARRAY("SexOr",SEQ))
if 'SEQ
QUIT
IF $PIECE($GET(ARRAY("SexOr",SEQ)),"^",2)'="E"
Begin DoDot:1
+6 ;validate sexual orientation code
SET CD=$PIECE($GET(ARRAY("SexOr",SEQ)),"^",1)
DO CHK^DIE(2.025,.01,,CD,.RES,"VAFCERR")
IF RES="^"
SET ERROR="-1^"_$$BLDERR("VAFCERR")
QUIT
+7 ;validate status
SET STATUS=$PIECE($GET(ARRAY("SexOr",SEQ)),"^",2)
DO CHK^DIE(2.025,.02,,STATUS,.RES,"VAFCERR")
IF RES="^"
SET ERROR="-1^"_$$BLDERR("VAFCERR")
QUIT
+8 ;validate tiu note ien
SET NOTE=$PIECE($GET(ARRAY("SexOr",SEQ)),"^",3)
IF NOTE'=""
IF '$DATA(^TIU(8925,NOTE,0))
SET ERROR="-1^Invalid TIU NOTE IEN"
QUIT
+9 ;build incoming list
SET INC(CD)=SEQ
End DoDot:1
IF ERROR
QUIT
+10 IF ERROR
QUIT ERROR
+11 ;
+12 ;validate sexual orientation description
+13 IF $GET(ARRAY("SexOrDes"))'=""
Begin DoDot:1
+14 DO CHK^DIE(2,.0251,,ARRAY("SexOrDes"),.RES,"VAFCERR")
IF RES="^"
SET ERROR="-1^"_$$BLDERR("VAFCERR")
QUIT
+15 IF $SELECT('$DATA(INC("OTH")):1,$PIECE($GET(ARRAY("SexOr",+$GET(INC("OTH")))),"^",2)'="A":1,1:0)
SET ERROR="-1^Sexual Orientation of 'Other' with 'Active' Status required to update 'SO' Description"
End DoDot:1
+16 IF ERROR
QUIT ERROR
+17 ;
+18 ;loop through current sexual orientations, validate data, build list
+19 SET SEQ=0
FOR
SET SEQ=$ORDER(^DPT(DFN,.025,SEQ))
if 'SEQ
QUIT
SET CD=$$GET1^DIQ(47.77,+$PIECE(^DPT(DFN,.025,SEQ,0),"^",1)_",",1)
IF CD'=""
Begin DoDot:1
+20 ;errored 'so' not passed
IF '$DATA(INC(CD))
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",2)'="E"
SET ERROR="-1^Patient currently has more Sexual Orientations defined, entire list must be passed"
+21 ;build current list, must included 'errored' so duplicates aren't built
SET CUR(CD)=SEQ
End DoDot:1
IF ERROR
QUIT
+22 IF ERROR
QUIT ERROR
+23 ;
+24 ;loop through incoming values
+25 SET CD=""
FOR
SET CD=$ORDER(INC(CD))
if CD=""
QUIT
Begin DoDot:1
+26 ;if not in current array set fda for an add
IF '$DATA(CUR(CD))
Begin DoDot:2
+27 ;sexual orientation
SET FDA(2.025,"+"_INC(CD)_","_DFN_",",.01)=CD
+28 ;status
SET FDA(2.025,"+"_INC(CD)_","_DFN_",",.02)=$PIECE(ARRAY("SexOr",INC(CD)),"^",2)
+29 ;date created
SET FDA(2.025,"+"_INC(CD)_","_DFN_",",.03)=TODAY
+30 ;date last updated
SET FDA(2.025,"+"_INC(CD)_","_DFN_",",.04)=TODAY
+31 ;note
IF $PIECE(ARRAY("SexOr",INC(CD)),"^",3)
SET FDA(2.025,"+"_INC(CD)_","_DFN_",",.05)="`"_$PIECE(ARRAY("SexOr",INC(CD)),"^",3)
+32 ;type of update - 'l'ocal
SET FDA(2.025,"+"_INC(CD)_","_DFN_",",.06)="L"
End DoDot:2
+33 ;
+34 ;if in current array set fda for an update
IF $DATA(CUR(CD))
Begin DoDot:2
+35 ;status change
IF $PIECE($GET(^DPT(DFN,.025,CUR(CD),0)),"^",2)'=$PIECE(ARRAY("SexOr",INC(CD)),"^",2)
SET FDA(2.025,CUR(CD)_","_DFN_",",.02)=$PIECE(ARRAY("SexOr",INC(CD)),"^",2)
+36 ;date created if null
IF $PIECE($GET(^DPT(DFN,.025,CUR(CD),0)),"^",3)=""
SET FDA(2.025,CUR(CD)_","_DFN_",",.03)=TODAY
+37 ;date last updated always updated to today
IF $PIECE($GET(^DPT(DFN,.025,CUR(CD),0)),"^",4)'=TODAY
SET FDA(2.025,CUR(CD)_","_DFN_",",.04)=TODAY
+38 ;note
IF $PIECE($GET(^DPT(DFN,.025,CUR(CD),0)),"^",5)'=$PIECE(ARRAY("SexOr",INC(CD)),"^",3)
SET FDA(2.025,CUR(CD)_","_DFN_",",.05)=$SELECT($PIECE(ARRAY("SexOr",INC(CD)),"^",3):"`"_$PIECE(ARRAY("SexOr",INC(CD)),"^",3),1:"@")
+39 ;type of update - 'l'ocal
IF $PIECE($GET(^DPT(DFN,.025,CUR(CD),0)),"^",6)'="L"
SET FDA(2.025,CUR(CD)_","_DFN_",",.06)="L"
End DoDot:2
End DoDot:1
+40 ;
+41 ;current business rules don't allow sexual orientation deletions for any reason
+42 ;loop through current values, if not in incoming array set FDA to delete
+43 ;S CD="" F S CD=$O(CUR(CD)) Q:CD="" I '$D(INC(CD)) S FDA(2.025,CUR(CD)_","_DFN_",",.01)="@"
+44 ;
+45 ;process sexual orientation description,set fda to add/update/delete
+46 ;delete a previously filed sexual orientation description if no 'so' of 'Other'
IF '$DATA(INC("OTH"))
IF $$GET1^DIQ(2,DFN_",",.0251)'=""
SET FDA(2,DFN_",",.0251)="@"
+47 IF $DATA(INC("OTH"))
Begin DoDot:1
+48 ;delete a previously filed sexual orientation description if status of incoming 'so' of 'Other' isn't active
IF $PIECE(ARRAY("SexOr",+INC("OTH")),"^",2)'="A"
IF $$GET1^DIQ(2,DFN_",",.0251)'=""
SET FDA(2,DFN_",",.0251)="@"
QUIT
+49 ;add/update sexual orientation description since 'so' of 'Other' is active
IF $PIECE(ARRAY("SexOr",+INC("OTH")),"^",2)="A"
IF $GET(ARRAY("SexOrDes"))'=""
IF ARRAY("SexOrDes")'=$$GET1^DIQ(2,DFN_",",.0251)
SET FDA1(2,DFN_",",.0251)=ARRAY("SexOrDes")
End DoDot:1
+50 ;
+51 IF UPDATE
Begin DoDot:1
+52 ;file sexual orientation data
IF $DATA(FDA)
SET ERROR=$$UPDATE(.FDA)
IF ERROR
QUIT
+53 ;file sexual orientation description separately so 'ahist' x-ref is properly built
IF $DATA(FDA1)
SET ERROR=$$UPDATE(.FDA1)
End DoDot:1
IF ERROR
QUIT ERROR
+54 ;
+55 QUIT ERROR
+56 ;
+57 ;
NOTE(DFN,ARRAY,UPDATE) ;tiu note deletion
+1 NEW ERROR,FDA,FDA1,GLO,LDLUP,NOTE,PREV,SEQ,SEQL
+2 SET ERROR=0
+3 ;
+4 SET NOTE=ARRAY("Note")
+5 ;I '$D(^TIU(8925,NOTE,0)) S ERROR="-1^Invalid TIU NOTE IEN" Q ;validate tiu note ien - no need to validate, could have already been deleted before calling api
+6 ;delete note from entries, keep list of modified sequences
SET SEQ=0
FOR
SET SEQ=$ORDER(^DPT(DFN,.025,SEQ))
if 'SEQ
QUIT
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",5)=NOTE
SET FDA(2.025,SEQ_","_DFN_",",.05)="@"
SET SEQL(SEQ)=""
+7 ;find most recent (last) date last update in history x-ref with tiu note, 'so' could already have a newer tiu note
SET GLO="^DPT(DFN,.025,""AHIST"")"
FOR
SET GLO=$QUERY(@GLO)
if GLO=""
QUIT
if ($QSUBSCRIPT(GLO,3)'="AHIST")
QUIT
IF $PIECE(@GLO,"^",1)=NOTE
SET LDLUP=$QSUBSCRIPT(GLO,4)
+8 IF '$DATA(FDA)&'$GET(LDLUP)
SET ERROR="-1^TIU NOTE doesn't exist in Patient's Sexual Orientation History"
QUIT ERROR
+9 ;delete note, let fileman fire x-ref's
IF UPDATE
IF $DATA(FDA)
SET ERROR=$$UPDATE(.FDA)
IF ERROR
QUIT
+10 ;delete orphaned x-ref with a tiu note, possibly missed due to 'so' already having newer note
IF UPDATE
SET GLO="^DPT(DFN,.025,""AHIST"")"
FOR
SET GLO=$QUERY(@GLO)
if GLO=""
QUIT
if ($QSUBSCRIPT(GLO,3)'="AHIST")
QUIT
IF $PIECE(@GLO,"^",1)=NOTE
KILL @GLO
SET SEQL($QSUBSCRIPT(GLO,6))=""
+11 ;
+12 ;this is the last 'date last updated' history x-ref's removed
IF $GET(LDLUP)
Begin DoDot:1
+13 ;more recent history exists in x-ref so don't update anything, since all 'so's always updated, no need to look at just modified 'so's
IF $ORDER(^DPT(DFN,.025,"AHIST",LDLUP))
QUIT
+14 ;
+15 ;previous history exists, possibly from another site on the same day
IF $ORDER(^DPT(DFN,.025,"AHIST",LDLUP+1),-1)
Begin DoDot:2
+16 ;find most recent past history for modified 'so's
SET GLO="^DPT(DFN,.025,""AHIST"",0)"
FOR
SET GLO=$QUERY(@GLO)
if GLO=""
QUIT
if $QSUBSCRIPT(GLO,3)'="AHIST"
QUIT
if $QSUBSCRIPT(GLO,4)>LDLUP
QUIT
IF $QSUBSCRIPT(GLO,6)
IF $DATA(SEQL($QSUBSCRIPT(GLO,6)))
Begin DoDot:3
+17 SET PREV($QSUBSCRIPT(GLO,6))=$QSUBSCRIPT(GLO,7)_"^"_$QSUBSCRIPT(GLO,8)_"^"_$QSUBSCRIPT(GLO,9)_"^"_$QSUBSCRIPT(GLO,4)_"^"_$PIECE($GET(@GLO),"^",1)_"^"_$QSUBSCRIPT(GLO,5)
+18 ;only set description if 'Other'
IF $QSUBSCRIPT(GLO,7)=5
SET PREV($QSUBSCRIPT(GLO,6),"SexOrDes")=$PIECE($GET(@GLO),"^",2)
End DoDot:3
End DoDot:2
+19 ;
+20 ;only loop through the modified sexual orientations
SET SEQ=0
FOR
SET SEQ=$ORDER(SEQL(SEQ))
if 'SEQ
QUIT
Begin DoDot:2
+21 ;if previous updates exist, roll back to how it looked
IF $DATA(PREV(SEQ))
Begin DoDot:3
+22 ;sexual orientation
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",1)'=$PIECE(PREV(SEQ),"^",1)
SET FDA(2.025,SEQ_","_DFN_",",.01)=$PIECE(PREV(SEQ),"^",1)
+23 ;status
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",2)'=$PIECE(PREV(SEQ),"^",2)
SET FDA(2.025,SEQ_","_DFN_",",.02)=$PIECE(PREV(SEQ),"^",2)
+24 ;date created
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",3)'=$PIECE(PREV(SEQ),"^",3)
SET FDA(2.025,SEQ_","_DFN_",",.03)=$PIECE(PREV(SEQ),"^",3)
+25 ;date last updated
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",4)'=$PIECE(PREV(SEQ),"^",4)
SET FDA(2.025,SEQ_","_DFN_",",.04)=$PIECE(PREV(SEQ),"^",4)
+26 ;note
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",5)'=$PIECE(PREV(SEQ),"^",5)
SET FDA(2.025,SEQ_","_DFN_",",.05)=$SELECT($PIECE(PREV(SEQ),"^",5):"`"_$PIECE(PREV(SEQ),"^",5),1:"@")
+27 ;type of update
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",6)'=$PIECE(PREV(SEQ),"^",6)
SET FDA(2.025,SEQ_","_DFN_",",.06)=$PIECE(PREV(SEQ),"^",6)
+28 ;update sexual orientation description
IF $PIECE($GET(^DPT(DFN,.025,SEQ,0)),"^",1)=5
IF $PIECE($GET(^DPT(DFN,.241)),"^",1)'=$PIECE(PREV(SEQ,"SexOrDes"),"^",1)
SET FDA1(2,DFN_",",.0251)=$SELECT($PIECE(PREV(SEQ,"SexOrDes"),"^",1)'="":$PIECE(PREV(SEQ,"SexOrDes"),"^",1),1:"@")
End DoDot:3
QUIT
+29 ;
+30 ;if previous updates did not exist then it was 'entered in error'
IF '$DATA(PREV(SEQ))
Begin DoDot:3
+31 ;status
SET FDA(2.025,SEQ_","_DFN_",",.02)="E"
+32 ;date last updated
SET FDA(2.025,SEQ_","_DFN_",",.04)=TODAY
+33 ;sexual orientation description (use fda instead of fda1 so it deletes prior to the fda1 from above filing)
SET FDA(2,DFN_",",.0251)="@"
End DoDot:3
End DoDot:2
+34 ;
End DoDot:1
+35 IF UPDATE
Begin DoDot:1
+36 IF $DATA(FDA)
SET ERROR=$$UPDATE(.FDA)
IF ERROR
QUIT
+37 ;file sexual orientation description separately so 'ahist' x-ref is properly built
IF $DATA(FDA1)
SET ERROR=$$UPDATE(.FDA1)
End DoDot:1
IF ERROR
QUIT ERROR
+38 ;
+39 QUIT ERROR
+40 ;
UPDATE(FDA) ;call update
+1 NEW VAFCERR
+2 IF '$DATA(FDA)
QUIT 0
+3 DO UPDATE^DIE("E","FDA",,"VAFCERR")
+4 IF $DATA(VAFCERR)
QUIT "-1^"_$$BLDERR("VAFCERR")
+5 QUIT 0
+6 ;
+7 ;
BLDERR(MSGROOT) ;build error from FileMan error message array
+1 NEW ERRARR,ERRMSG,I
+2 DO MSG^DIALOG("AE",.ERRARR,"","",MSGROOT)
+3 SET ERRMSG=""
SET I=0
FOR
SET I=$ORDER(ERRARR(I))
if 'I
QUIT
SET ERRMSG=ERRMSG_$SELECT(ERRMSG]"":" ",1:"")_$GET(ERRARR(I))
+4 QUIT ERRMSG
+5 ;
+6 ;
SETSO ;set logic for 'AHIST' x-ref of Sexual Orientation Multiple (#.025) in Patient (#2) file
+1 ;only set history when 'so' has a 'non-errored' status or tiu note not being deleted
IF $SELECT(X(2)="E":0,X(5)=""&(X1(5)'=""):0,1:1)
IF X(1)'=""
IF X(2)'=""
IF X(3)'=""
IF X(4)'=""
IF X(6)'=""
Begin DoDot:1
+2 ;only local updates can have tiu notes
SET ^DPT(DA(1),.025,"AHIST",X(4),X(6),DA,X(1),X(2),X(3))=$SELECT(X(6)="L":X(5),1:"")
End DoDot:1
+3 QUIT
+4 ;
KILLSO ;kill logic for 'AHIST' x-ref of Sexual Orientation Multiple (#.025) in Patient (#2) file
+1 ;only kill history if status going to 'error', DLUP is 'rolling back' or tiu note is being deleted
IF $SELECT(X(2)'=""&(X2(2)="E"):1,X(4)'=""&(X2(4)'="")&(X2(4)<X(4)):1,X(5)'=""&(X2(5)=""):1,1:0)
IF X(1)'=""
IF X(2)'=""
IF X(3)'=""
IF X(4)'=""
IF X(6)'=""
Begin DoDot:1
+2 ;attempt to kill off both 'local' and 'remote' x-ref, sync from mpi will looklook like a 'remote' update
+3 ;kill 'local' x-ref
KILL ^DPT(DA(1),.025,"AHIST",X(4),"L",DA,X(1),X(2),X(3))
+4 ;kill 'remote' x-ref except on tiu note deletion, only 'local' can set/have a tiu note
IF $SELECT(X(5)'=""&(X2(5)=""):0,1:1)
KILL ^DPT(DA(1),.025,"AHIST",X(4),"R",DA,X(1),X(2),X(3))
End DoDot:1
+5 QUIT
+6 ;
SETSOD ;set logic for 'AHIST' x-ref of Sexual Orientation Description (#.0251) in Patient (#2) file
+1 ;only active sexual orientation 'Other' can have a description
IF X(1)'=""
NEW XX,XXDA0,XXDA
SET XXDA=$ORDER(^DPT(DA,.025,"B",5,0))
IF XXDA
IF $PIECE($GET(^DPT(DA,.025,XXDA,0)),"^",2)="A"
SET XXDA0=^(0)
Begin DoDot:1
+2 FOR XX=1:1:6
SET XX(XX)=$PIECE(XXDA0,"^",XX)
+3 IF XX(1)'=""
IF XX(2)'=""
IF XX(3)'=""
IF XX(4)'=""
IF XX(6)'=""
IF $DATA(^DPT(DA,.025,"AHIST",XX(4),XX(6),XXDA,XX(1),XX(2),XX(3)))
SET $PIECE(^(XX(3)),"^",2)=X(1)
End DoDot:1
+4 QUIT
+5 ;
KILLSOD ;kill logic for 'AHIST' x-ref of Sexual Orientation Description (#.0251) in Patient (#2) file
+1 NEW XX,XXDA0,XXDA
SET XXDA=$ORDER(^DPT(DA,.025,"B",5,0))
IF XXDA
SET XXDA0=$GET(^DPT(DA,.025,XXDA,0))
Begin DoDot:1
+2 FOR XX=1:1:6
SET XX(XX)=$PIECE(XXDA0,"^",XX)
+3 IF XX(1)'=""
IF XX(2)'=""
IF XX(3)'=""
IF XX(4)'=""
IF XX(6)'=""
IF $DATA(^DPT(DA,.025,"AHIST",XX(4),XX(6),XXDA,XX(1),XX(2),XX(3)))
SET $PIECE(^(XX(3)),"^",2)=""
End DoDot:1
+4 QUIT
+5 ;
