VAFCTFU2 ;BHM/CMC-Utilities for the Treating Facility file 391.91, CONTINUED ; 4/21/2010
;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
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
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
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
;
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)),"^")
;
; 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
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
S INSTIEN=$P($G(DGCN(0)),"^",2),LSTA=$$STA^XUAF4(INSTIEN)
I $E(LSTA,1,5)="200MH",$P($G(DGCN(0)),"^",8)'=1 Q
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)=
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 SDFN=$P(NODE,"^"),STATUS=$P(NODE,"^",2)
..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"
F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP S TFIEN=$O(^(LP,"")) 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
;
VAFCTFU2 ;BHM/CMC-Utilities for the Treating Facility file 391.91, CONTINUED ; 4/21/2010
+1 ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
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
+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 IF TYPE'="NI"
IF TYPE'="PI"
SET LIST(1)="-1^Invalid Id Type."
QUIT
+27 IF ASSIGN'="USVHA"
IF ASSIGN'="USDOD"
SET LIST(1)="-1^Invalid Assigning Authority."
QUIT
+28 IF SITE']""
SET LIST(1)="-1^Missing Assigning Facility."
QUIT
+29 ; find the ien for the station number
+30 SET SITEIEN=$ORDER(^DIC(4,"D",SITE,0))
+31 IF 'SITEIEN
SET LIST(1)="-1^Assigning Facility is not defined in database."
QUIT
+32 ;
+33 IF TYPE="PI"
IF ASSIGN="USVHA"
SET DFN=ID
+34 IF TYPE="NI"
IF ASSIGN="USVHA"
IF SITE="200M"
SET ICN=ID
+35 IF TYPE="NI"
IF ASSIGN="USDOD"
IF SITE="200DOD"
SET EDIPI=ID
+36 IF $DATA(ICN)
SET DFN=$$GETDFN^MPIF001(ICN)
Begin DoDot:1
+37 IF +DFN<0
SET LIST(1)="-1^ICN is not known"
QUIT
+38 SET SITEIEN=$$IEN^XUAF4($PIECE($$SITE^VASITE,"^",3))
End DoDot:1
IF $DATA(LIST(1))
QUIT
+39 ;
+40 IF $DATA(DFN)
SET ICN=$$GETICN^MPIF001(DFN)
+41 ; DFN should be defined, but ICN may not.
+42 ; I $D(EDIPI) S ICN=$$GETICN(EDIPI)
+43 ; check EDIPI
+44 IF $DATA(EDIPI)
IF '$DATA(^DGCN(391.91,"ASCR",EDIPI,SITEIEN))
Begin DoDot:1
+45 SET LIST(1)="-1^EDIPI Record is unknown at this facility"
End DoDot:1
QUIT
+46 IF $DATA(EDIPI)
IF $DATA(^DGCN(391.91,"ASCR",EDIPI,SITEIEN))
Begin DoDot:1
+47 SET EN=$ORDER(^DGCN(391.91,"ASCR",EDIPI,SITEIEN,0))
+48 SET DFN=$PIECE($GET(^DGCN(391.91,EN,0)),"^")
End DoDot:1
+49 ;
+50 ; if ICN is not defined, it is OK, but DFN should be defined
+51 ; I $G(ICN)<0 S LIST(1)=ICN Q
+52 ; bad input, such as Id^NI^USVHA^123
+53 IF '$GET(DFN)
SET LIST(1)="-1^Invalid input"
QUIT
+54 ; check DFN and Site to be matching an entry in file #391.91
+55 IF '$ORDER(^DGCN(391.91,"APAT",DFN,SITEIEN,0))
Begin DoDot:1
+56 SET LIST(1)="-1^Id as '"_ID_"'"_" is not in database"
End DoDot:1
QUIT
+57 ; DFN should be defined, but ICN may not.
+58 SET X=$$QUERYTF($PIECE($GET(ICN),"V"),"LIST")
+59 IF $PIECE(X,U)="1"
SET LIST(1)="-1"_U_$PIECE(X,U,2)
QUIT
+60 ;S DR=".01;13;99",DIC=4,DIQ(0)="E",DIQ="VAFCTFU2"
+61 ;F VAFC=0:0 S VAFC=$O(LIST(VAFC)) Q:VAFC="" D
+62 ;.K VAFCTFU2
+63 ;.S DA=+LIST(VAFC)
+64 ;.D EN^DIQ1
+65 ;.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)
+66 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
+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
+5 SET INSTIEN=$PIECE($GET(DGCN(0)),"^",2)
SET LSTA=$$STA^XUAF4(INSTIEN)
+6 IF $EXTRACT(LSTA,1,5)="200MH"
IF $PIECE($GET(DGCN(0)),"^",8)'=1
QUIT
+7 SET ID=$PIECE(DGCN(0),"^")
SET SITE=$PIECE(DGCN(0),"^",2)
IF SITE'=""
SET SITEN=$$STA^XUAF4(SITE)
+8 SET IDTYPE="PI"
+9 IF SITEN="200DOD"!(SITEN["200N")
SET IDTYPE="NI"
+10 SET ASSAUTH="USVHA"
+11 IF SITEN="200DOD"
SET 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 SET SOURCE=""
SET FOUND=0
+24 IF $DATA(^DGCN(391.91,TFIEN,1))
Begin DoDot:1
+25 SET EN=0
FOR
SET EN=$ORDER(^DGCN(391.91,TFIEN,1,EN))
IF EN=""
QUIT
Begin DoDot:2
+26 SET NODE=$GET(^DGCN(391.91,TFIEN,1,EN,0))
+27 SET SDFN=$PIECE(NODE,"^")
SET STATUS=$PIECE(NODE,"^",2)
+28 IF SDFN'=""
SET CTR=CTR+1
SET @ARY@(CTR)=SDFN_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN_"^"_STATUS
SET FOUND=1
End DoDot:2
End DoDot:1
+29 IF FOUND=0
SET CTR=CTR+1
SET @ARY@(CTR)=""_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN
+30 QUIT
+31 ;
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 FOR LP=0:0
SET LP=$ORDER(^DGCN(391.91,"APAT",PDFN,LP))
IF 'LP
QUIT
SET TFIEN=$ORDER(^(LP,""))
DO SET(TFIEN,ARY,.CTR)
+28 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 ;
