- 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 Feb 19, 2025@00:28:33 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 ;