VAFCREL ;ALB/CMC-API/RPC FOR RELATIONSHIP DATA ;4 MARCH 2020
;;5.3;Registration;**1001,997**;Jun 06, 1996;Build 42
;
Q
GET(RETURN,DFN) ;
;RPC VAFC GETRELATIONSHIPS
;DFN - ien from Patient file (#2)
;RETURN:
;The RETURN(0) array will always be returned.
;RETURN(0) - If relationships found for a given DFN, it will contain 1 in the 1st piece and "RELATIONSHIPS RETURNED" text in 2nd piece
;If no relationships not found for a given DFN, it will contain 0 in the 1st piece and "NO RELATIONSHIPS RETURNED" text in 2nd piece
;If error condition, it will contain -1 in the 1st piece and error message text in 2nd piece
; RETURN(0)="1^RELATIONSHIPS RETURNED"
; RETURN(0)="0^NO RELATIONSHIPS RETURNED"
; RETURN(0)="-1^ERROR:Timeout Limit Reached" *** note: timeout limit is 10 seconds Possible error conditions
; RETURN(0)="-1^ERROR:Internal Error"
; RETURN(0)="-1^ERROR:Unknown ID"
; RETURN(1-n) - If relationships found for a given DFN, it will contain the list of Relationships in the following format:
; ICN^RelationshipType^RelationshipTypeDisplay^RelationshipRoleCode^RelationshipStatus^RelationshipStatusDisplay^RelationshipStatusChangeDate^AssignedName
; RETURN(1)="1002345678V123456^CGP^CAREGIVER: PRIMARY^QUAL^ACTIVE^APPROVED^20200220^Jones, William M"
; RETURN(2)="1901234590V098766^CGS^CAREGIVER: SECONDARY^QUAL^ACTIVE^APPROVED^20200220^Jones, Donna"
; RETURN(3)="1002345678V123456^SONC^SON^QUAL^ACTIVE^ACTIVE^20200220^Jones, Mike"
; RETURN(4)="1901234590V098766^CGP^CAREGIVER: PRIMARY^QUAL^TERMINATED^BENEFIT END DATE^20170220^Jones, Donna"
; RETURN(5)="1007879802V000909^SPS^SPOUSE^QUAL^ACTIVE^^ACTIVE^20120301^Jones, Donna"
; RETURN(6)="1089022222V123423^BRO^BROTHER^QUAL^ACTIVE^ACTIVE^20111202^Jones, Joseph"
;
I DFN="" S RETURN(0)="-1^ERROR:Unknown ID" Q
I $G(^DPT(DFN,0))=""!($G(^DPT(DFN,-9))'="") S RETURN(0)="-1^ERROR:Unknown ID" Q
;
N ICN,MPIXML,PROCID,QUOTE
S PROCID=$P($$PARAM^HLCS2,"^",3),QUOTE=""""
S ICN=$$GETICN^MPIF001(DFN)
I +ICN=-1 S RETURN(0)="-1^ERROR:Unknown ID" Q
I $E(ICN,1,3)=$P($$SITE^VASITE,"^",3) S RETURN(0)="-1^ERROR:Unknown ID" Q
;
S MPIXML="<IDM_REQUEST type='RMS' subtype='GET'><IDMHEADER>"
S MPIXML=MPIXML_"<SENDING_FACILITY>"_$P($$SITE^VASITE,"^",3)_"</SENDING_FACILITY>"
S MPIXML=MPIXML_"<PROCESSING_ID>"_PROCID_"</PROCESSING_ID>"
I $G(DUZ)>0 D
.S MPIXML=MPIXML_"<TRIGGER><ACTOR><IDENTIFIER type="_QUOTE_"PN"_QUOTE_"><ID>"_DUZ_"</ID>"
.S MPIXML=MPIXML_"<SOURCE>"_$P($$SITE^VASITE,"^",3)_"</SOURCE><ISSUER>USVHA</ISSUER></IDENTIFIER></ACTOR></TRIGGER></IDMHEADER>"
S MPIXML=MPIXML_"<ARGUMENTS><ARGUMENT name='sourceId'><IDENTIFIER type='NI' subtype='IDM'>"
S MPIXML=MPIXML_"<ID>"_ICN_"</ID>"
S MPIXML=MPIXML_"</IDENTIFIER></ARGUMENT></ARGUMENTS></IDM_REQUEST>"
;
N IEN,HTTPS,SVC,RES,ARR
S IEN=$O(^MPIF(984.8,"B","TWO","")),HTTPS=$P($G(^MPIF(984.8,IEN,0)),"^",4)
I HTTPS=0!(HTTPS="") S SVC=$$GETPROXY^XOBWLIB("MPI_PSIM_EXECUTE","MPI_PSIM_EXECUTE")
I HTTPS=1 S SVC=$$GETPROXY^XOBWLIB("MPI_PSIM_NEW EXECUTE","MPI_PSIM_NEW EXECUTE")
XML ;
S RETURN(0)="-1^ERROR:Internal Error" ;DEFAULTING setting error handling **997
N $ETRAP,$ESTACK S $ETRAP="DO ERROR^MPIFHWSC"
S RES=SVC.execute(MPIXML)
;
I RES="" S RETURN(0)="-1^ERROR:Timeout Limit Reached" Q
I RES["hibernate" S RETURN(0)="-1^ERROR:Internal Error" Q
I RES'["<RESULT type='AA'>" S RETURN(0)="-1^ERROR:Internal Error" Q
I RES["<RESULT type='AA'>" D Q
.D PARSE(RES,.ARR,.RETURN)
.I RETURN(0)'="1^RELATIONSHIPS RETURNED" Q
.I $G(ARR("ICN"))'=ICN S RETURN(0)="-1^ERROR:Internal Error" Q
.D REL(.ARR,.RETURN) ;HAVE RELATIONSHIPS
S RETURN(0)="-1^ERROR:Internal Error" Q
;
Q
PARSE(XML,ARR,RETURN) ;Parsing XML into ARR values
N PROF,IDENT,CNT,REL,STOP
S PROF=$P(XML,"<PROFILE>",2) I PROF="" S RETURN(0)="0^NO RELATIONSHIPS RETURNED" Q
S IDENT=$P(PROF,"</IDENTIFIER>") I IDENT="" S RETURN(0)="-1^ERROR:Internal Errror" Q
S ARR("ICN")=$P($P(IDENT,"<ID>",2),"</ID>") I ARR("ICN")="" S RETURN(0)="-1^ERROR:Internal Error" Q
I RES'["RELATIONSHIP" S RETURN(0)="0^NO RELATIONSHIPS RETURNED" Q
S STOP=0
F CNT=1:1 Q:STOP=1 D
.S ARR("REL",CNT)=$P(XML,"</RELATIONSHIP>",CNT)
.I CNT=1 S ARR("REL",CNT)="<RELATIONSHIP"_$P(ARR("REL",CNT),"<RELATIONSHIP",2)
.I ARR("REL",CNT)="</PROFILE></RESULT></IDM_RESPONSE>" S STOP=1 K ARR("REL",CNT)
I $G(ARR("REL",1))="" S RETURN(0)="0^NO RELATIONSHIPS RETURNED" Q
I $G(ARR("REL",1))'="" S RETURN(0)="1^RELATIONSHIPS RETURNED"
Q
REL(ARR,RETURN) ;SETUP RELATIONSHIPS INTO RETURN
N CNT,ICN,TYPE,STAT,ROLE,TDIS,STAT,SDIS,SDAT,NAME
S CNT=0
;ICN^RelationshipType^RelationshipTypeDisplay^RelationshipRoleCode^RelationshipStatus^RelationshipStatusDisplay^RelationshipStatusChangeDate^AssignedName
;ICN^TYPE^TDIS^ROLE^STAT^SDIS^SDAT^NAME
F S CNT=$O(ARR("REL",CNT)) Q:CNT="" D
.S ICN=$P($P(ARR("REL",CNT),"<ID>",2),"</ID>")
.S TYPE=$P($P(ARR("REL",CNT),"subtype=",2)," direction"),TYPE=$TR(TYPE,"'")
.S TDIS=$P($P(ARR("REL",CNT),"<ATTRIBUTE type='REL_TYPE_DESC'><VALUE>",2),"</VALUE>")
.S ROLE=$P($P(ARR("REL",CNT),"direction=",2),"status"),ROLE=$TR(ROLE,"'"),ROLE=$TR(ROLE," ")
.S STAT=$P($P(ARR("REL",CNT),"status='",2),"'>")
.S SDIS=$P($P(ARR("REL",CNT),"<ATTRIBUTE type='REL_STATUS_DESC'><VALUE>",2),"</VALUE>")
.S SDAT=$P($P(ARR("REL",CNT),"<ATTRIBUTE type='EFFECTIVE_DATE'><VALUE>",2),"</VALUE>")
.S NAME=$P($P(ARR("REL",CNT),"<ATTRIBUTE type='DISPLAY_NAME'><VALUE>",2),"</VALUE>")
.S RETURN(CNT)=ICN_"^"_TYPE_"^"_TDIS_"^"_ROLE_"^"_STAT_"^"_SDIS_"^"_SDAT_"^"_NAME
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCREL 5565 printed Nov 22, 2024@18:12:20 Page 2
VAFCREL ;ALB/CMC-API/RPC FOR RELATIONSHIP DATA ;4 MARCH 2020
+1 ;;5.3;Registration;**1001,997**;Jun 06, 1996;Build 42
+2 ;
+3 QUIT
GET(RETURN,DFN) ;
+1 ;RPC VAFC GETRELATIONSHIPS
+2 ;DFN - ien from Patient file (#2)
+3 ;RETURN:
+4 ;The RETURN(0) array will always be returned.
+5 ;RETURN(0) - If relationships found for a given DFN, it will contain 1 in the 1st piece and "RELATIONSHIPS RETURNED" text in 2nd piece
+6 ;If no relationships not found for a given DFN, it will contain 0 in the 1st piece and "NO RELATIONSHIPS RETURNED" text in 2nd piece
+7 ;If error condition, it will contain -1 in the 1st piece and error message text in 2nd piece
+8 ; RETURN(0)="1^RELATIONSHIPS RETURNED"
+9 ; RETURN(0)="0^NO RELATIONSHIPS RETURNED"
+10 ; RETURN(0)="-1^ERROR:Timeout Limit Reached" *** note: timeout limit is 10 seconds Possible error conditions
+11 ; RETURN(0)="-1^ERROR:Internal Error"
+12 ; RETURN(0)="-1^ERROR:Unknown ID"
+13 ; RETURN(1-n) - If relationships found for a given DFN, it will contain the list of Relationships in the following format:
+14 ; ICN^RelationshipType^RelationshipTypeDisplay^RelationshipRoleCode^RelationshipStatus^RelationshipStatusDisplay^RelationshipStatusChangeDate^AssignedName
+15 ; RETURN(1)="1002345678V123456^CGP^CAREGIVER: PRIMARY^QUAL^ACTIVE^APPROVED^20200220^Jones, William M"
+16 ; RETURN(2)="1901234590V098766^CGS^CAREGIVER: SECONDARY^QUAL^ACTIVE^APPROVED^20200220^Jones, Donna"
+17 ; RETURN(3)="1002345678V123456^SONC^SON^QUAL^ACTIVE^ACTIVE^20200220^Jones, Mike"
+18 ; RETURN(4)="1901234590V098766^CGP^CAREGIVER: PRIMARY^QUAL^TERMINATED^BENEFIT END DATE^20170220^Jones, Donna"
+19 ; RETURN(5)="1007879802V000909^SPS^SPOUSE^QUAL^ACTIVE^^ACTIVE^20120301^Jones, Donna"
+20 ; RETURN(6)="1089022222V123423^BRO^BROTHER^QUAL^ACTIVE^ACTIVE^20111202^Jones, Joseph"
+21 ;
+22 IF DFN=""
SET RETURN(0)="-1^ERROR:Unknown ID"
QUIT
+23 IF $GET(^DPT(DFN,0))=""!($GET(^DPT(DFN,-9))'="")
SET RETURN(0)="-1^ERROR:Unknown ID"
QUIT
+24 ;
+25 NEW ICN,MPIXML,PROCID,QUOTE
+26 SET PROCID=$PIECE($$PARAM^HLCS2,"^",3)
SET QUOTE=""""
+27 SET ICN=$$GETICN^MPIF001(DFN)
+28 IF +ICN=-1
SET RETURN(0)="-1^ERROR:Unknown ID"
QUIT
+29 IF $EXTRACT(ICN,1,3)=$PIECE($$SITE^VASITE,"^",3)
SET RETURN(0)="-1^ERROR:Unknown ID"
QUIT
+30 ;
+31 SET MPIXML="<IDM_REQUEST type='RMS' subtype='GET'><IDMHEADER>"
+32 SET MPIXML=MPIXML_"<SENDING_FACILITY>"_$PIECE($$SITE^VASITE,"^",3)_"</SENDING_FACILITY>"
+33 SET MPIXML=MPIXML_"<PROCESSING_ID>"_PROCID_"</PROCESSING_ID>"
+34 IF $GET(DUZ)>0
Begin DoDot:1
+35 SET MPIXML=MPIXML_"<TRIGGER><ACTOR><IDENTIFIER type="_QUOTE_"PN"_QUOTE_"><ID>"_DUZ_"</ID>"
+36 SET MPIXML=MPIXML_"<SOURCE>"_$PIECE($$SITE^VASITE,"^",3)_"</SOURCE><ISSUER>USVHA</ISSUER></IDENTIFIER></ACTOR></TRIGGER></IDMHEADER>"
End DoDot:1
+37 SET MPIXML=MPIXML_"<ARGUMENTS><ARGUMENT name='sourceId'><IDENTIFIER type='NI' subtype='IDM'>"
+38 SET MPIXML=MPIXML_"<ID>"_ICN_"</ID>"
+39 SET MPIXML=MPIXML_"</IDENTIFIER></ARGUMENT></ARGUMENTS></IDM_REQUEST>"
+40 ;
+41 NEW IEN,HTTPS,SVC,RES,ARR
+42 SET IEN=$ORDER(^MPIF(984.8,"B","TWO",""))
SET HTTPS=$PIECE($GET(^MPIF(984.8,IEN,0)),"^",4)
+43 IF HTTPS=0!(HTTPS="")
SET SVC=$$GETPROXY^XOBWLIB("MPI_PSIM_EXECUTE","MPI_PSIM_EXECUTE")
+44 IF HTTPS=1
SET SVC=$$GETPROXY^XOBWLIB("MPI_PSIM_NEW EXECUTE","MPI_PSIM_NEW EXECUTE")
XML ;
+1 ;DEFAULTING setting error handling **997
SET RETURN(0)="-1^ERROR:Internal Error"
+2 NEW $ETRAP,$ESTACK
SET $ETRAP="DO ERROR^MPIFHWSC"
+3 SET RES=SVC.execute(MPIXML)
+4 ;
+5 IF RES=""
SET RETURN(0)="-1^ERROR:Timeout Limit Reached"
QUIT
+6 IF RES["hibernate"
SET RETURN(0)="-1^ERROR:Internal Error"
QUIT
+7 IF RES'["<RESULT type='AA'>"
SET RETURN(0)="-1^ERROR:Internal Error"
QUIT
+8 IF RES["<RESULT type='AA'>"
Begin DoDot:1
+9 DO PARSE(RES,.ARR,.RETURN)
+10 IF RETURN(0)'="1^RELATIONSHIPS RETURNED"
QUIT
+11 IF $GET(ARR("ICN"))'=ICN
SET RETURN(0)="-1^ERROR:Internal Error"
QUIT
+12 ;HAVE RELATIONSHIPS
DO REL(.ARR,.RETURN)
End DoDot:1
QUIT
+13 SET RETURN(0)="-1^ERROR:Internal Error"
QUIT
+14 ;
+15 QUIT
PARSE(XML,ARR,RETURN) ;Parsing XML into ARR values
+1 NEW PROF,IDENT,CNT,REL,STOP
+2 SET PROF=$PIECE(XML,"<PROFILE>",2)
IF PROF=""
SET RETURN(0)="0^NO RELATIONSHIPS RETURNED"
QUIT
+3 SET IDENT=$PIECE(PROF,"</IDENTIFIER>")
IF IDENT=""
SET RETURN(0)="-1^ERROR:Internal Errror"
QUIT
+4 SET ARR("ICN")=$PIECE($PIECE(IDENT,"<ID>",2),"</ID>")
IF ARR("ICN")=""
SET RETURN(0)="-1^ERROR:Internal Error"
QUIT
+5 IF RES'["RELATIONSHIP"
SET RETURN(0)="0^NO RELATIONSHIPS RETURNED"
QUIT
+6 SET STOP=0
+7 FOR CNT=1:1
if STOP=1
QUIT
Begin DoDot:1
+8 SET ARR("REL",CNT)=$PIECE(XML,"</RELATIONSHIP>",CNT)
+9 IF CNT=1
SET ARR("REL",CNT)="<RELATIONSHIP"_$PIECE(ARR("REL",CNT),"<RELATIONSHIP",2)
+10 IF ARR("REL",CNT)="</PROFILE></RESULT></IDM_RESPONSE>"
SET STOP=1
KILL ARR("REL",CNT)
End DoDot:1
+11 IF $GET(ARR("REL",1))=""
SET RETURN(0)="0^NO RELATIONSHIPS RETURNED"
QUIT
+12 IF $GET(ARR("REL",1))'=""
SET RETURN(0)="1^RELATIONSHIPS RETURNED"
+13 QUIT
REL(ARR,RETURN) ;SETUP RELATIONSHIPS INTO RETURN
+1 NEW CNT,ICN,TYPE,STAT,ROLE,TDIS,STAT,SDIS,SDAT,NAME
+2 SET CNT=0
+3 ;ICN^RelationshipType^RelationshipTypeDisplay^RelationshipRoleCode^RelationshipStatus^RelationshipStatusDisplay^RelationshipStatusChangeDate^AssignedName
+4 ;ICN^TYPE^TDIS^ROLE^STAT^SDIS^SDAT^NAME
+5 FOR
SET CNT=$ORDER(ARR("REL",CNT))
if CNT=""
QUIT
Begin DoDot:1
+6 SET ICN=$PIECE($PIECE(ARR("REL",CNT),"<ID>",2),"</ID>")
+7 SET TYPE=$PIECE($PIECE(ARR("REL",CNT),"subtype=",2)," direction")
SET TYPE=$TRANSLATE(TYPE,"'")
+8 SET TDIS=$PIECE($PIECE(ARR("REL",CNT),"<ATTRIBUTE type='REL_TYPE_DESC'><VALUE>",2),"</VALUE>")
+9 SET ROLE=$PIECE($PIECE(ARR("REL",CNT),"direction=",2),"status")
SET ROLE=$TRANSLATE(ROLE,"'")
SET ROLE=$TRANSLATE(ROLE," ")
+10 SET STAT=$PIECE($PIECE(ARR("REL",CNT),"status='",2),"'>")
+11 SET SDIS=$PIECE($PIECE(ARR("REL",CNT),"<ATTRIBUTE type='REL_STATUS_DESC'><VALUE>",2),"</VALUE>")
+12 SET SDAT=$PIECE($PIECE(ARR("REL",CNT),"<ATTRIBUTE type='EFFECTIVE_DATE'><VALUE>",2),"</VALUE>")
+13 SET NAME=$PIECE($PIECE(ARR("REL",CNT),"<ATTRIBUTE type='DISPLAY_NAME'><VALUE>",2),"</VALUE>")
+14 SET RETURN(CNT)=ICN_"^"_TYPE_"^"_TDIS_"^"_ROLE_"^"_STAT_"^"_SDIS_"^"_SDAT_"^"_NAME
End DoDot:1
+15 QUIT
