VAFCTFU2 ;BHM/CMC,CKN-Utilities for the Treating Facility file 391.91, CONTINUED ;2/2/21 10:41
;;5.3;Registration;**821,856,863,981,1026,1042**;Aug 13, 1993;Build 5
TFL(LIST,PT) ;for this PT [patient] (either DFN, ICN or EDIPI) return the list of treating facilities
; CALLED FROM RPC VAFC LOCAL GET CORRESPONDINGIDS
; PT values -->
;ICN example: 1008520438V882204^NI^USVHA^200M
;DFN example: 100000511^PI^USVHA^500
;EDIPI example: 852043888^NI^USDOD^200DOD
;
; Return:
; This will return the ICN and the list of treating facilities in the following.
;
; format:
; Id^IdType^AssigningAuthority^AssigningFacility^IdStatus
;
; Examples:
; RESULT(1)="1011232151V598646^NI^200M^A"
; RESULT(2)="7168937^PI^USVHA^500^A"
; RESULT(3)="852043888^NI^USDOD^200DOD^A"
;
N X,ICN,DA,DR,VAFCTFU1,DIC,DIQ,VAFC,DFN,EDIPI,ASSIGN,ID,SITE,TYPE,IEN,SITEIEN
S X="MPIF001" X ^%ZOSF("TEST") I '$T S LIST(1)="-1^MPI Not Installed" Q
; clear "return" variable
K LIST
; what do we have
S TYPE=$P(PT,"^",2),SITE=$P(PT,"^",4),ID=$P(PT,"^"),ASSIGN=$P(PT,"^",3)
; check input data
I ID']"" S LIST(1)="-1^Id is not defined." Q
;**126 ANY ID IS ALLOWED
;I TYPE'="NI",TYPE'="PI" S LIST(1)="-1^Invalid Id Type." Q
;I ASSIGN'="USVHA",ASSIGN'="USDOD" S LIST(1)="-1^Invalid Assigning Authority." Q
I SITE']"" S LIST(1)="-1^Missing Assigning Facility." Q
; find the ien for the station number
S SITEIEN=$O(^DIC(4,"D",SITE,0))
I 'SITEIEN S LIST(1)="-1^Assigning Facility is not defined in database." Q
;*1026 ALLOW ANY ID TO BE USED FOR LOOKUP IN TF LIST TO FIND THE FULL ID LIST
I ID["V",TYPE="NI",ASSIGN="USVHA",SITE="200M" S ICN=ID ;ICN is lookup value
S IEN=$O(^DGCN(391.91,"AISS",ID,ASSIGN,TYPE,SITEIEN,0))
;
;**1042, VAMPI-8215 (dri) - retrieve tf's from new person tf file (#391.92)
;if id passed doesn't exist in tf file (#391.91) and the icn (if passed) is not
;known to the patient file (#2), look in new person tf file (#391.92) for tf's
;if no list of new person tf's returned continue on to look at #391.91
I IEN=""&($$GETDFN^MPIF001($G(ICN))<0) D I $D(LIST) Q
.N FAC,SOURCEID,IDTYP,AA,IDENSTAT,CTR,NPTFIEN,NPIEN,VAFCARR
.S CTR=1
.I $D(^DGCN(391.92,"AISS",ID,TYPE,ASSIGN,+$$IEN^XUAF4(SITE))) S NPTFIEN=+$O(^DGCN(391.92,"AISS",ID,TYPE,ASSIGN,$$IEN^XUAF4(SITE),0)),NPIEN=$$GET1^DIQ(391.92,NPTFIEN_",",.01,"I") I NPIEN D
..S NPTFIEN=0 F S NPTFIEN=$O(^DGCN(391.92,"B",NPIEN,NPTFIEN)) Q:'NPTFIEN D
...D GETS^DIQ(391.92,NPTFIEN_",",".02;.03;.04;.05;.06","I","VAFCARR")
...S FAC=VAFCARR(391.92,NPTFIEN_",",.02,"I")
...S SOURCEID=VAFCARR(391.92,NPTFIEN_",",.03,"I")
...S IDTYP=VAFCARR(391.92,NPTFIEN_",",.04,"I")
...S AA=VAFCARR(391.92,NPTFIEN_",",.05,"I")
...S IDENSTAT=$S($D(^DGCN(391.919,"ACRNR",FAC)):"C",1:VAFCARR(391.92,NPTFIEN_",",.06,"I"))
...S LIST(CTR)=SOURCEID_U_IDTYP_U_AA_U_$$STA^XUAF4(FAC)_U_IDENSTAT S CTR=CTR+1
;
I IEN="",$G(ICN)="" S LIST(1)="-1^Id as '"_ID_"'"_" is not in database" Q
;
I IEN'="" S DFN=$P(^DGCN(391.91,IEN,0),"^")
I $G(ICN)="" S ICN=$$GETICN^MPIF001(DFN)
I $G(ICN)'="" S DFN=$$GETDFN^MPIF001(ICN)
S X=$$QUERYTF($P($G(ICN),"V"),"LIST")
;**1026 ANY ID IS ALLOWED, INCLUDING ONE THAT ISN'T THE DFN LOCALLY
;I TYPE="PI",ASSIGN="USVHA" S DFN=ID
;I TYPE="NI",ASSIGN="USVHA",SITE="200M" S ICN=ID
;I TYPE="NI",ASSIGN="USDOD",SITE="200DOD" S EDIPI=ID
;I $D(ICN) S DFN=$$GETDFN^MPIF001(ICN) D Q:$D(LIST(1))
;. I +DFN<0 S LIST(1)="-1^ICN is not known" Q
;. S SITEIEN=$$IEN^XUAF4($P($$SITE^VASITE,"^",3))
;;
;I $D(DFN) S ICN=$$GETICN^MPIF001(DFN)
;; DFN should be defined, but ICN may not.
;; I $D(EDIPI) S ICN=$$GETICN(EDIPI)
;; check EDIPI
;;I $D(EDIPI),'$D(^DGCN(391.91,"ASCR",EDIPI,SITEIEN)) D Q
;;. S LIST(1)="-1^EDIPI Record is unknown at this facility"
;;I $D(EDIPI),$D(^DGCN(391.91,"ASCR",EDIPI,SITEIEN)) D
;;.S EN=$O(^DGCN(391.91,"ASCR",EDIPI,SITEIEN,0))
;;.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
;;**856 MVI 1371 (ckn)
;Use new xref AISS appropriately to retrieve DFN from EDIPI
;I $D(EDIPI)=""!(ASSIGN="")!(TYPE="")!(SITEIEN="") S LIST(1)="-1^Insufficient data" Q
;I $D(EDIPI),'$D(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN)) D Q
;. S LIST(1)="-1^EDIPI Record is unknown at this facility"
;I $D(EDIPI),$D(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN)) D
;.S EN=$O(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN,0))
;.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
;;
;; if ICN is not defined, it is OK, but DFN should be defined
;; I $G(ICN)<0 S LIST(1)=ICN Q
;; bad input, such as Id^NI^USVHA^123
;I '$G(DFN) S LIST(1)="-1^Invalid input" Q
;; check DFN and Site to be matching an entry in file #391.91
;I '$O(^DGCN(391.91,"APAT",DFN,SITEIEN,0)) D Q
;. S LIST(1)="-1^Id as '"_ID_"'"_" is not in database"
;; DFN should be defined, but ICN may not.
;S X=$$QUERYTF($P($G(ICN),"V"),"LIST")
;I $P(X,U)="1" S LIST(1)="-1"_U_$P(X,U,2) Q
;S DR=".01;13;99",DIC=4,DIQ(0)="E",DIQ="VAFCTFU2"
;F VAFC=0:0 S VAFC=$O(LIST(VAFC)) Q:VAFC="" D
;.K VAFCTFU2
;.S DA=+LIST(VAFC)
;.D EN^DIQ1
;.S LIST(VAFC)=VAFCTFU2(4,+LIST(VAFC),99,"E")_"^"_VAFCTFU2(4,+LIST(VAFC),.01,"E")_"^"_$P(LIST(VAFC),"^",2)_"^"_$P(LIST(VAFC),"^",3)_"^"_VAFCTFU2(4,+LIST(VAFC),13,"E")_"^"_$P(LIST(VAFC),"^",4)
Q
GETICN(EDIPI) ;return the ICN when EDIPI is passed
N EN,DFN,ICN,IEN
S IEN=$$IEN^XUAF4("200DOD")
I 'IEN Q "-1^Unknown Assigning Facility."
I '$D(^DGCN(391.91,"ASCR",EDIPI,IEN)) Q "-1^EDIPI Record is unknown at this facility"
I $D(^DGCN(391.91,"ASCR",EDIPI,IEN)) D
.S EN=$O(^DGCN(391.91,"ASCR",EDIPI,$$IEN^XUAF4("200DOD"),""))
.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
.I DFN'="" S ICN=$$GETICN^MPIF001(DFN)
.I DFN="" S ICN="-1^No Site Record associated with this entry"
Q ICN
;
SET(TFIEN,ARY,CTR) ;This sets the array with the treating facility list.
; Ex ARY(1)=<ID> ^ <ID TYPE> ^ <Assigning Authority> ^ <Assigning Facility> ^ <ID Status>
N DGCN,INSTIEN,LSTA,SOURCE,EN,NODE,SDFN,STATUS,SITEN,ID,IDTYPE,SITE,ASSAUTH,FOUND,NODE0,NODE2
S DGCN(0)=$G(^DGCN(391.91,TFIEN,0)),SITEN=""
;** FROM DG*5.3*800 - (ckn) - Quit if IPP field is not set for 200MH record - removed in **863 MVI 2544
S INSTIEN=$P($G(DGCN(0)),"^",2),LSTA=$$STA^XUAF4(INSTIEN)
;I $E(LSTA,1,5)="200MH",$P($G(DGCN(0)),"^",8)'=1 Q ;include all MHV records MVI 2544 **863
S ID=$P(DGCN(0),"^"),SITE=$P(DGCN(0),"^",2) I SITE'="" S SITEN=$$STA^XUAF4(SITE)
;S IDTYPE="PI"
;I SITEN="200DOD"!(SITEN["200N") S IDTYPE="NI"
;S ASSAUTH="USVHA"
;I SITEN="200DOD" S ASSAUTH="USDOD"
; GET SOURCE ID AND SOURCE STATUS - CAN BE MORE THAN ONE
;^DGCN(391.91,14842,0)=7169806^17942
;^DGCN(391.91,14842,1,0)=^391.9101A^2^2
;^DGCN(391.91,14842,1,1,0)=1^A
;^DGCN(391.91,14842,1,2,0)=2^H
;^DGCN(391.91,14842,1,"B",1,1)=
;^DGCN(391.91,14842,1,"B",2,2)=
;^DGCN(391.91,1708,0)=7169806^500^3081204.152808^^^^1
;^DGCN(391.91,1708,1,0)=^391.9101A^1^1
;^DGCN(391.91,1708,1,1,0)=27^H
;^DGCN(391.91,1708,1,"B",27,1)=
;**856 - MVI 1371 (ckn)
;After DG*5.3*837 - TREATING FACILITY LIST file #391.91 does not
;store Source Id value in SOURCE ID multiple field. This field is
;is moved to top level. We no longer need to loop through SOURNCE ID
;multiple to get the values.
;S SOURCE="",FOUND=0
;I $D(^DGCN(391.91,TFIEN,1)) D
;.S EN=0 F S EN=$O(^DGCN(391.91,TFIEN,1,EN)) Q:EN="" D
;..;S NODE=$G(^DGCN(391.91,TFIEN,1,EN,0))
S NODE0=$G(^DGCN(391.91,TFIEN,0))
S NODE2=$G(^DGCN(391.91,TFIEN,2))
S SDFN=$P(NODE2,"^",2),STATUS=$P(NODE2,"^",3),IDTYPE=$P(NODE0,"^",9)
S ASSAUTH=$P(NODE2,"^")
I SITEN="200DOD"!(SITEN["200N") S IDTYPE="NI"
I SITEN="200DOD" S ASSAUTH="USDOD"
I IDTYPE="" S IDTYPE="PI"
I ASSAUTH="" S ASSAUTH="USVHA"
I SITEN["200N"&(IDTYPE="NI")&(ASSAUTH="USVHA") S ASSAUTH=""
;S SDFN=$P(NODE,"^"),STATUS=$P(NODE,"^",2)
;**981, Story 961754 (jfw) - Allow for Status of CERNER if NOT currently MERGED
S:(STATUS'="H") STATUS=$S($D(^DGCN(391.919,"ACRNR",SITEN)):"C",1:STATUS)
I SDFN'="" S CTR=CTR+1,@ARY@(CTR)=SDFN_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN_"^"_STATUS,FOUND=1
;I FOUND=0 S CTR=CTR+1,@ARY@(CTR)=""_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN
Q
;
QUERYTF(PAT,ARY) ;a query for Treating Facility.
;INPUT PAT - The patient's ICN
; ARY - The array in which to return the Treating facility info.
;OUTPUT A list of the Treating Facilities in the array provided from
; the parameter. It will be in the structure of x(1), x(2) etc.
; Ex X(1)=<ID> ^ <ID TYPE> ^ <Assigning Authority> ^ <Assigning Facility> ^ <ID Status>
;
; This is also a function call. If there is an error then a
; 1^error description will be returned.
;
; *** If no data is found the array will not be populated and
; a 1^error description will be returned.
;
N PDFN,VAFCER,LP,CTR
;
; ICN is not required, comment out
; I '$G(PAT)!('$D(ARY)) S VAFCER="1^Parameter missing." G QUERYTFQ
I ('$D(ARY)) S VAFCER="1^Parameter missing." G QUERYTFQ
S VAFCER=0,CTR=1
S X="MPIF001" X ^%ZOSF("TEST") I '$T G QUERYTFQ
; ICN is not required, comment out
; S PDFN=$$GETDFN^MPIF001(PAT)
; I PDFN<0 S VAFCER="1^No patient DFN." G QUERYTFQ
S PDFN=$G(DFN)
I '$G(PDFN) S VAFCER="1^DFN is not defined." G QUERYTFQ
;SET FIRST ENTRY TO BE THE ICN - FULL ICN - PAT IS NOT THE ICN
S @ARY@(CTR)=$$GETICN^MPIF001(PDFN)_"^NI^USVHA^200M^A"
;**856 - MVI 1371 (ckn)
;Loop through all TFIENs for site
;F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP S TFIEN=$O(^(LP,"")) D SET(TFIEN,ARY,.CTR)
F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP D
.S TFIEN=0 F S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,LP,TFIEN)) Q:'TFIEN D
..D SET(TFIEN,ARY,.CTR)
I $D(@ARY)'>9 S VAFCER="1^Could not find Treating Facilities"
QUERYTFQ Q VAFCER
;
NEWTF(RESULT,DFN,EDIPI) ;
; for MPIC_2019
; called from RPC: VAFC NEW NC TREATING FACILITY
; Input:
; DFN: Vista Patient Identifier will be the PATIENT file (#2) IEN (aka DFN)
; example of DFN="7168937"
;
; EDIPI: The DOD Identifier will be EDIPI data with the
; following format:
; Id^IdType^AssigningAuthority^AssigningFacility
; example: 852043888^NI^USDOD^200DOD
;
; Return:
; This will return a list of treating facilities in the following.
;
; format:
; Id^IdType^AssigningAuthority^AssigningFacility^IdStatus[^NEW]
;
; Examples:
; RESULT(1)="7168937^PI^USVHA^500^A"
; RESULT(2)="85204388^NI^USDOD^200DOD^A^NEW"
; Note: If there is data in the 6th piece of the RESULT(<number>),
; with data value as "NEW", then it means that the entry was
; newly created in the TREATING FACILITY LIST (#391.91) file
; by this RPC call.
;
N X,TYPE,SITE,ID,ASSIGN,PTDFN,LP,CTR,NCTFIEN,ERROR,II
S X="MPIF001" X ^%ZOSF("TEST") I '$T S RESULT(1)="-1^MPI Not Installed" Q
; clear "return" variable
K RESULT
; input parameters
S PTDFN=$G(DFN)
I 'PTDFN S RESULT(1)="-1^Invalid DFN:"""_PTDFN_"""" Q
; check the field #.01 data in patient entry
I $P($G(^DPT(PTDFN,0)),"^")']"" D Q
. S RESULT(1)="-1^No patient in database for the DFN:"_PTDFN
;
S ID=$P(EDIPI,"^"),TYPE=$P(EDIPI,"^",2),ASSIGN=$P(EDIPI,"^",3)
S SITE=$P(EDIPI,"^",4)
;
I ID']"" S RESULT(1)="-1^Id is not defined." Q
I TYPE'="NI" S RESULT(1)="-1^Invalid Id Type." Q
I ASSIGN'="USDOD" S RESULT(1)="-1^Invalid Assigning Authority." Q
I SITE'="200DOD" S RESULT(1)="-1^Invalid Assigning Facility." Q
S SITEIEN=$O(^DIC(4,"D","200DOD",0))
I 'SITEIEN S RESULT(1)="-1^Assigning Facility is not defined in database." Q
;
; get ien of file #391.91
S NCTFIEN=$O(^DGCN(391.91,"APAT",PTDFN,SITEIEN,0))
;
; Assigning Facility as "200DOD" of the patient is already existed
; in file #391.91
S CTR=0
I NCTFIEN D Q
. N TFIEN
. F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PTDFN,LP)) Q:'LP S TFIEN=$O(^(LP,0)) D
.. Q:'TFIEN
.. ; retrieve entry in file #391.91
.. D SET(TFIEN,"RESULT",.CTR)
;
; add new entry to file #391.91
D FILENEW^VAFCTFU(PTDFN,SITEIEN,"","","",.ERROR,"",ID,"A")
I $D(ERROR(SITEIEN)) D Q
. S RESULT(1)="-1^"_$G(ERROR(SITEIEN))
;
; for Cache client/server model in case that there is a delay for
; retrieving the new created entry.
F II=1:1:5 Q:$O(^DGCN(391.91,"APAT",PTDFN,SITEIEN,0)) H II
; retrieving the results
F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PTDFN,LP)) Q:'LP S TFIEN=$O(^(LP,0)) D
. Q:'TFIEN
. ; retrieve entry in file #391.91
. D SET(TFIEN,"RESULT",.CTR)
. I $P($G(RESULT(CTR)),"^",3)="USDOD" S RESULT(CTR)=RESULT(CTR)_"^NEW"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCTFU2 12575 printed Sep 23, 2025@20:38:25 Page 2
VAFCTFU2 ;BHM/CMC,CKN-Utilities for the Treating Facility file 391.91, CONTINUED ;2/2/21 10:41
+1 ;;5.3;Registration;**821,856,863,981,1026,1042**;Aug 13, 1993;Build 5
TFL(LIST,PT) ;for this PT [patient] (either DFN, ICN or EDIPI) return the list of treating facilities
+1 ; CALLED FROM RPC VAFC LOCAL GET CORRESPONDINGIDS
+2 ; PT values -->
+3 ;ICN example: 1008520438V882204^NI^USVHA^200M
+4 ;DFN example: 100000511^PI^USVHA^500
+5 ;EDIPI example: 852043888^NI^USDOD^200DOD
+6 ;
+7 ; Return:
+8 ; This will return the ICN and the list of treating facilities in the following.
+9 ;
+10 ; format:
+11 ; Id^IdType^AssigningAuthority^AssigningFacility^IdStatus
+12 ;
+13 ; Examples:
+14 ; RESULT(1)="1011232151V598646^NI^200M^A"
+15 ; RESULT(2)="7168937^PI^USVHA^500^A"
+16 ; RESULT(3)="852043888^NI^USDOD^200DOD^A"
+17 ;
+18 NEW X,ICN,DA,DR,VAFCTFU1,DIC,DIQ,VAFC,DFN,EDIPI,ASSIGN,ID,SITE,TYPE,IEN,SITEIEN
+19 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET LIST(1)="-1^MPI Not Installed"
QUIT
+20 ; clear "return" variable
+21 KILL LIST
+22 ; what do we have
+23 SET TYPE=$PIECE(PT,"^",2)
SET SITE=$PIECE(PT,"^",4)
SET ID=$PIECE(PT,"^")
SET ASSIGN=$PIECE(PT,"^",3)
+24 ; check input data
+25 IF ID']""
SET LIST(1)="-1^Id is not defined."
QUIT
+26 ;**126 ANY ID IS ALLOWED
+27 ;I TYPE'="NI",TYPE'="PI" S LIST(1)="-1^Invalid Id Type." Q
+28 ;I ASSIGN'="USVHA",ASSIGN'="USDOD" S LIST(1)="-1^Invalid Assigning Authority." Q
+29 IF SITE']""
SET LIST(1)="-1^Missing Assigning Facility."
QUIT
+30 ; find the ien for the station number
+31 SET SITEIEN=$ORDER(^DIC(4,"D",SITE,0))
+32 IF 'SITEIEN
SET LIST(1)="-1^Assigning Facility is not defined in database."
QUIT
+33 ;*1026 ALLOW ANY ID TO BE USED FOR LOOKUP IN TF LIST TO FIND THE FULL ID LIST
+34 ;ICN is lookup value
IF ID["V"
IF TYPE="NI"
IF ASSIGN="USVHA"
IF SITE="200M"
SET ICN=ID
+35 SET IEN=$ORDER(^DGCN(391.91,"AISS",ID,ASSIGN,TYPE,SITEIEN,0))
+36 ;
+37 ;**1042, VAMPI-8215 (dri) - retrieve tf's from new person tf file (#391.92)
+38 ;if id passed doesn't exist in tf file (#391.91) and the icn (if passed) is not
+39 ;known to the patient file (#2), look in new person tf file (#391.92) for tf's
+40 ;if no list of new person tf's returned continue on to look at #391.91
+41 IF IEN=""&($$GETDFN^MPIF001($GET(ICN))<0)
Begin DoDot:1
+42 NEW FAC,SOURCEID,IDTYP,AA,IDENSTAT,CTR,NPTFIEN,NPIEN,VAFCARR
+43 SET CTR=1
+44 IF $DATA(^DGCN(391.92,"AISS",ID,TYPE,ASSIGN,+$$IEN^XUAF4(SITE)))
SET NPTFIEN=+$ORDER(^DGCN(391.92,"AISS",ID,TYPE,ASSIGN,$$IEN^XUAF4(SITE),0))
SET NPIEN=$$GET1^DIQ(391.92,NPTFIEN_",",.01,"I")
IF NPIEN
Begin DoDot:2
+45 SET NPTFIEN=0
FOR
SET NPTFIEN=$ORDER(^DGCN(391.92,"B",NPIEN,NPTFIEN))
if 'NPTFIEN
QUIT
Begin DoDot:3
+46 DO GETS^DIQ(391.92,NPTFIEN_",",".02;.03;.04;.05;.06","I","VAFCARR")
+47 SET FAC=VAFCARR(391.92,NPTFIEN_",",.02,"I")
+48 SET SOURCEID=VAFCARR(391.92,NPTFIEN_",",.03,"I")
+49 SET IDTYP=VAFCARR(391.92,NPTFIEN_",",.04,"I")
+50 SET AA=VAFCARR(391.92,NPTFIEN_",",.05,"I")
+51 SET IDENSTAT=$SELECT($DATA(^DGCN(391.919,"ACRNR",FAC)):"C",1:VAFCARR(391.92,NPTFIEN_",",.06,"I"))
+52 SET LIST(CTR)=SOURCEID_U_IDTYP_U_AA_U_$$STA^XUAF4(FAC)_U_IDENSTAT
SET CTR=CTR+1
End DoDot:3
End DoDot:2
End DoDot:1
IF $DATA(LIST)
QUIT
+53 ;
+54 IF IEN=""
IF $GET(ICN)=""
SET LIST(1)="-1^Id as '"_ID_"'"_" is not in database"
QUIT
+55 ;
+56 IF IEN'=""
SET DFN=$PIECE(^DGCN(391.91,IEN,0),"^")
+57 IF $GET(ICN)=""
SET ICN=$$GETICN^MPIF001(DFN)
+58 IF $GET(ICN)'=""
SET DFN=$$GETDFN^MPIF001(ICN)
+59 SET X=$$QUERYTF($PIECE($GET(ICN),"V"),"LIST")
+60 ;**1026 ANY ID IS ALLOWED, INCLUDING ONE THAT ISN'T THE DFN LOCALLY
+61 ;I TYPE="PI",ASSIGN="USVHA" S DFN=ID
+62 ;I TYPE="NI",ASSIGN="USVHA",SITE="200M" S ICN=ID
+63 ;I TYPE="NI",ASSIGN="USDOD",SITE="200DOD" S EDIPI=ID
+64 ;I $D(ICN) S DFN=$$GETDFN^MPIF001(ICN) D Q:$D(LIST(1))
+65 ;. I +DFN<0 S LIST(1)="-1^ICN is not known" Q
+66 ;. S SITEIEN=$$IEN^XUAF4($P($$SITE^VASITE,"^",3))
+67 ;;
+68 ;I $D(DFN) S ICN=$$GETICN^MPIF001(DFN)
+69 ;; DFN should be defined, but ICN may not.
+70 ;; I $D(EDIPI) S ICN=$$GETICN(EDIPI)
+71 ;; check EDIPI
+72 ;;I $D(EDIPI),'$D(^DGCN(391.91,"ASCR",EDIPI,SITEIEN)) D Q
+73 ;;. S LIST(1)="-1^EDIPI Record is unknown at this facility"
+74 ;;I $D(EDIPI),$D(^DGCN(391.91,"ASCR",EDIPI,SITEIEN)) D
+75 ;;.S EN=$O(^DGCN(391.91,"ASCR",EDIPI,SITEIEN,0))
+76 ;;.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
+77 ;;**856 MVI 1371 (ckn)
+78 ;Use new xref AISS appropriately to retrieve DFN from EDIPI
+79 ;I $D(EDIPI)=""!(ASSIGN="")!(TYPE="")!(SITEIEN="") S LIST(1)="-1^Insufficient data" Q
+80 ;I $D(EDIPI),'$D(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN)) D Q
+81 ;. S LIST(1)="-1^EDIPI Record is unknown at this facility"
+82 ;I $D(EDIPI),$D(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN)) D
+83 ;.S EN=$O(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN,0))
+84 ;.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
+85 ;;
+86 ;; if ICN is not defined, it is OK, but DFN should be defined
+87 ;; I $G(ICN)<0 S LIST(1)=ICN Q
+88 ;; bad input, such as Id^NI^USVHA^123
+89 ;I '$G(DFN) S LIST(1)="-1^Invalid input" Q
+90 ;; check DFN and Site to be matching an entry in file #391.91
+91 ;I '$O(^DGCN(391.91,"APAT",DFN,SITEIEN,0)) D Q
+92 ;. S LIST(1)="-1^Id as '"_ID_"'"_" is not in database"
+93 ;; DFN should be defined, but ICN may not.
+94 ;S X=$$QUERYTF($P($G(ICN),"V"),"LIST")
+95 ;I $P(X,U)="1" S LIST(1)="-1"_U_$P(X,U,2) Q
+96 ;S DR=".01;13;99",DIC=4,DIQ(0)="E",DIQ="VAFCTFU2"
+97 ;F VAFC=0:0 S VAFC=$O(LIST(VAFC)) Q:VAFC="" D
+98 ;.K VAFCTFU2
+99 ;.S DA=+LIST(VAFC)
+100 ;.D EN^DIQ1
+101 ;.S LIST(VAFC)=VAFCTFU2(4,+LIST(VAFC),99,"E")_"^"_VAFCTFU2(4,+LIST(VAFC),.01,"E")_"^"_$P(LIST(VAFC),"^",2)_"^"_$P(LIST(VAFC),"^",3)_"^"_VAFCTFU2(4,+LIST(VAFC),13,"E")_"^"_$P(LIST(VAFC),"^",4)
+102 QUIT
GETICN(EDIPI) ;return the ICN when EDIPI is passed
+1 NEW EN,DFN,ICN,IEN
+2 SET IEN=$$IEN^XUAF4("200DOD")
+3 IF 'IEN
QUIT "-1^Unknown Assigning Facility."
+4 IF '$DATA(^DGCN(391.91,"ASCR",EDIPI,IEN))
QUIT "-1^EDIPI Record is unknown at this facility"
+5 IF $DATA(^DGCN(391.91,"ASCR",EDIPI,IEN))
Begin DoDot:1
+6 SET EN=$ORDER(^DGCN(391.91,"ASCR",EDIPI,$$IEN^XUAF4("200DOD"),""))
+7 SET DFN=$PIECE($GET(^DGCN(391.91,EN,0)),"^")
+8 IF DFN'=""
SET ICN=$$GETICN^MPIF001(DFN)
+9 IF DFN=""
SET ICN="-1^No Site Record associated with this entry"
End DoDot:1
+10 QUIT ICN
+11 ;
SET(TFIEN,ARY,CTR) ;This sets the array with the treating facility list.
+1 ; Ex ARY(1)=<ID> ^ <ID TYPE> ^ <Assigning Authority> ^ <Assigning Facility> ^ <ID Status>
+2 NEW DGCN,INSTIEN,LSTA,SOURCE,EN,NODE,SDFN,STATUS,SITEN,ID,IDTYPE,SITE,ASSAUTH,FOUND,NODE0,NODE2
+3 SET DGCN(0)=$GET(^DGCN(391.91,TFIEN,0))
SET SITEN=""
+4 ;** FROM DG*5.3*800 - (ckn) - Quit if IPP field is not set for 200MH record - removed in **863 MVI 2544
+5 SET INSTIEN=$PIECE($GET(DGCN(0)),"^",2)
SET LSTA=$$STA^XUAF4(INSTIEN)
+6 ;I $E(LSTA,1,5)="200MH",$P($G(DGCN(0)),"^",8)'=1 Q ;include all MHV records MVI 2544 **863
+7 SET ID=$PIECE(DGCN(0),"^")
SET SITE=$PIECE(DGCN(0),"^",2)
IF SITE'=""
SET SITEN=$$STA^XUAF4(SITE)
+8 ;S IDTYPE="PI"
+9 ;I SITEN="200DOD"!(SITEN["200N") S IDTYPE="NI"
+10 ;S ASSAUTH="USVHA"
+11 ;I SITEN="200DOD" S ASSAUTH="USDOD"
+12 ; GET SOURCE ID AND SOURCE STATUS - CAN BE MORE THAN ONE
+13 ;^DGCN(391.91,14842,0)=7169806^17942
+14 ;^DGCN(391.91,14842,1,0)=^391.9101A^2^2
+15 ;^DGCN(391.91,14842,1,1,0)=1^A
+16 ;^DGCN(391.91,14842,1,2,0)=2^H
+17 ;^DGCN(391.91,14842,1,"B",1,1)=
+18 ;^DGCN(391.91,14842,1,"B",2,2)=
+19 ;^DGCN(391.91,1708,0)=7169806^500^3081204.152808^^^^1
+20 ;^DGCN(391.91,1708,1,0)=^391.9101A^1^1
+21 ;^DGCN(391.91,1708,1,1,0)=27^H
+22 ;^DGCN(391.91,1708,1,"B",27,1)=
+23 ;**856 - MVI 1371 (ckn)
+24 ;After DG*5.3*837 - TREATING FACILITY LIST file #391.91 does not
+25 ;store Source Id value in SOURCE ID multiple field. This field is
+26 ;is moved to top level. We no longer need to loop through SOURNCE ID
+27 ;multiple to get the values.
+28 ;S SOURCE="",FOUND=0
+29 ;I $D(^DGCN(391.91,TFIEN,1)) D
+30 ;.S EN=0 F S EN=$O(^DGCN(391.91,TFIEN,1,EN)) Q:EN="" D
+31 ;..;S NODE=$G(^DGCN(391.91,TFIEN,1,EN,0))
+32 SET NODE0=$GET(^DGCN(391.91,TFIEN,0))
+33 SET NODE2=$GET(^DGCN(391.91,TFIEN,2))
+34 SET SDFN=$PIECE(NODE2,"^",2)
SET STATUS=$PIECE(NODE2,"^",3)
SET IDTYPE=$PIECE(NODE0,"^",9)
+35 SET ASSAUTH=$PIECE(NODE2,"^")
+36 IF SITEN="200DOD"!(SITEN["200N")
SET IDTYPE="NI"
+37 IF SITEN="200DOD"
SET ASSAUTH="USDOD"
+38 IF IDTYPE=""
SET IDTYPE="PI"
+39 IF ASSAUTH=""
SET ASSAUTH="USVHA"
+40 IF SITEN["200N"&(IDTYPE="NI")&(ASSAUTH="USVHA")
SET ASSAUTH=""
+41 ;S SDFN=$P(NODE,"^"),STATUS=$P(NODE,"^",2)
+42 ;**981, Story 961754 (jfw) - Allow for Status of CERNER if NOT currently MERGED
+43 if (STATUS'="H")
SET STATUS=$SELECT($DATA(^DGCN(391.919,"ACRNR",SITEN)):"C",1:STATUS)
+44 IF SDFN'=""
SET CTR=CTR+1
SET @ARY@(CTR)=SDFN_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN_"^"_STATUS
SET FOUND=1
+45 ;I FOUND=0 S CTR=CTR+1,@ARY@(CTR)=""_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN
+46 QUIT
+47 ;
QUERYTF(PAT,ARY) ;a query for Treating Facility.
+1 ;INPUT PAT - The patient's ICN
+2 ; ARY - The array in which to return the Treating facility info.
+3 ;OUTPUT A list of the Treating Facilities in the array provided from
+4 ; the parameter. It will be in the structure of x(1), x(2) etc.
+5 ; Ex X(1)=<ID> ^ <ID TYPE> ^ <Assigning Authority> ^ <Assigning Facility> ^ <ID Status>
+6 ;
+7 ; This is also a function call. If there is an error then a
+8 ; 1^error description will be returned.
+9 ;
+10 ; *** If no data is found the array will not be populated and
+11 ; a 1^error description will be returned.
+12 ;
+13 NEW PDFN,VAFCER,LP,CTR
+14 ;
+15 ; ICN is not required, comment out
+16 ; I '$G(PAT)!('$D(ARY)) S VAFCER="1^Parameter missing." G QUERYTFQ
+17 IF ('$DATA(ARY))
SET VAFCER="1^Parameter missing."
GOTO QUERYTFQ
+18 SET VAFCER=0
SET CTR=1
+19 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
GOTO QUERYTFQ
+20 ; ICN is not required, comment out
+21 ; S PDFN=$$GETDFN^MPIF001(PAT)
+22 ; I PDFN<0 S VAFCER="1^No patient DFN." G QUERYTFQ
+23 SET PDFN=$GET(DFN)
+24 IF '$GET(PDFN)
SET VAFCER="1^DFN is not defined."
GOTO QUERYTFQ
+25 ;SET FIRST ENTRY TO BE THE ICN - FULL ICN - PAT IS NOT THE ICN
+26 SET @ARY@(CTR)=$$GETICN^MPIF001(PDFN)_"^NI^USVHA^200M^A"
+27 ;**856 - MVI 1371 (ckn)
+28 ;Loop through all TFIENs for site
+29 ;F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP S TFIEN=$O(^(LP,"")) D SET(TFIEN,ARY,.CTR)
+30 FOR LP=0:0
SET LP=$ORDER(^DGCN(391.91,"APAT",PDFN,LP))
if 'LP
QUIT
Begin DoDot:1
+31 SET TFIEN=0
FOR
SET TFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,LP,TFIEN))
if 'TFIEN
QUIT
Begin DoDot:2
+32 DO SET(TFIEN,ARY,.CTR)
End DoDot:2
End DoDot:1
+33 IF $DATA(@ARY)'>9
SET VAFCER="1^Could not find Treating Facilities"
QUERYTFQ QUIT VAFCER
+1 ;
NEWTF(RESULT,DFN,EDIPI) ;
+1 ; for MPIC_2019
+2 ; called from RPC: VAFC NEW NC TREATING FACILITY
+3 ; Input:
+4 ; DFN: Vista Patient Identifier will be the PATIENT file (#2) IEN (aka DFN)
+5 ; example of DFN="7168937"
+6 ;
+7 ; EDIPI: The DOD Identifier will be EDIPI data with the
+8 ; following format:
+9 ; Id^IdType^AssigningAuthority^AssigningFacility
+10 ; example: 852043888^NI^USDOD^200DOD
+11 ;
+12 ; Return:
+13 ; This will return a list of treating facilities in the following.
+14 ;
+15 ; format:
+16 ; Id^IdType^AssigningAuthority^AssigningFacility^IdStatus[^NEW]
+17 ;
+18 ; Examples:
+19 ; RESULT(1)="7168937^PI^USVHA^500^A"
+20 ; RESULT(2)="85204388^NI^USDOD^200DOD^A^NEW"
+21 ; Note: If there is data in the 6th piece of the RESULT(<number>),
+22 ; with data value as "NEW", then it means that the entry was
+23 ; newly created in the TREATING FACILITY LIST (#391.91) file
+24 ; by this RPC call.
+25 ;
+26 NEW X,TYPE,SITE,ID,ASSIGN,PTDFN,LP,CTR,NCTFIEN,ERROR,II
+27 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET RESULT(1)="-1^MPI Not Installed"
QUIT
+28 ; clear "return" variable
+29 KILL RESULT
+30 ; input parameters
+31 SET PTDFN=$GET(DFN)
+32 IF 'PTDFN
SET RESULT(1)="-1^Invalid DFN:"""_PTDFN_""""
QUIT
+33 ; check the field #.01 data in patient entry
+34 IF $PIECE($GET(^DPT(PTDFN,0)),"^")']""
Begin DoDot:1
+35 SET RESULT(1)="-1^No patient in database for the DFN:"_PTDFN
End DoDot:1
QUIT
+36 ;
+37 SET ID=$PIECE(EDIPI,"^")
SET TYPE=$PIECE(EDIPI,"^",2)
SET ASSIGN=$PIECE(EDIPI,"^",3)
+38 SET SITE=$PIECE(EDIPI,"^",4)
+39 ;
+40 IF ID']""
SET RESULT(1)="-1^Id is not defined."
QUIT
+41 IF TYPE'="NI"
SET RESULT(1)="-1^Invalid Id Type."
QUIT
+42 IF ASSIGN'="USDOD"
SET RESULT(1)="-1^Invalid Assigning Authority."
QUIT
+43 IF SITE'="200DOD"
SET RESULT(1)="-1^Invalid Assigning Facility."
QUIT
+44 SET SITEIEN=$ORDER(^DIC(4,"D","200DOD",0))
+45 IF 'SITEIEN
SET RESULT(1)="-1^Assigning Facility is not defined in database."
QUIT
+46 ;
+47 ; get ien of file #391.91
+48 SET NCTFIEN=$ORDER(^DGCN(391.91,"APAT",PTDFN,SITEIEN,0))
+49 ;
+50 ; Assigning Facility as "200DOD" of the patient is already existed
+51 ; in file #391.91
+52 SET CTR=0
+53 IF NCTFIEN
Begin DoDot:1
+54 NEW TFIEN
+55 FOR LP=0:0
SET LP=$ORDER(^DGCN(391.91,"APAT",PTDFN,LP))
if 'LP
QUIT
SET TFIEN=$ORDER(^(LP,0))
Begin DoDot:2
+56 if 'TFIEN
QUIT
+57 ; retrieve entry in file #391.91
+58 DO SET(TFIEN,"RESULT",.CTR)
End DoDot:2
End DoDot:1
QUIT
+59 ;
+60 ; add new entry to file #391.91
+61 DO FILENEW^VAFCTFU(PTDFN,SITEIEN,"","","",.ERROR,"",ID,"A")
+62 IF $DATA(ERROR(SITEIEN))
Begin DoDot:1
+63 SET RESULT(1)="-1^"_$GET(ERROR(SITEIEN))
End DoDot:1
QUIT
+64 ;
+65 ; for Cache client/server model in case that there is a delay for
+66 ; retrieving the new created entry.
+67 FOR II=1:1:5
if $ORDER(^DGCN(391.91,"APAT",PTDFN,SITEIEN,0))
QUIT
HANG II
+68 ; retrieving the results
+69 FOR LP=0:0
SET LP=$ORDER(^DGCN(391.91,"APAT",PTDFN,LP))
if 'LP
QUIT
SET TFIEN=$ORDER(^(LP,0))
Begin DoDot:1
+70 if 'TFIEN
QUIT
+71 ; retrieve entry in file #391.91
+72 DO SET(TFIEN,"RESULT",.CTR)
+73 IF $PIECE($GET(RESULT(CTR)),"^",3)="USDOD"
SET RESULT(CTR)=RESULT(CTR)_"^NEW"
End DoDot:1
+74 QUIT
+75 ;
