Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VAFCTFU2

VAFCTFU2.m

Go to the documentation of this file.
  1. 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
  1. 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
  1. ; PT values -->
  1. ;ICN example: 1008520438V882204^NI^USVHA^200M
  1. ;DFN example: 100000511^PI^USVHA^500
  1. ;EDIPI example: 852043888^NI^USDOD^200DOD
  1. ;
  1. ; Return:
  1. ; This will return the ICN and the list of treating facilities in the following.
  1. ;
  1. ; format:
  1. ; Id^IdType^AssigningAuthority^AssigningFacility^IdStatus
  1. ;
  1. ; Examples:
  1. ; RESULT(1)="1011232151V598646^NI^200M^A"
  1. ; RESULT(2)="7168937^PI^USVHA^500^A"
  1. ; RESULT(3)="852043888^NI^USDOD^200DOD^A"
  1. ;
  1. N X,ICN,DA,DR,VAFCTFU1,DIC,DIQ,VAFC,DFN,EDIPI,ASSIGN,ID,SITE,TYPE,IEN,SITEIEN
  1. S X="MPIF001" X ^%ZOSF("TEST") I '$T S LIST(1)="-1^MPI Not Installed" Q
  1. ; clear "return" variable
  1. K LIST
  1. ; what do we have
  1. S TYPE=$P(PT,"^",2),SITE=$P(PT,"^",4),ID=$P(PT,"^"),ASSIGN=$P(PT,"^",3)
  1. ; check input data
  1. I ID']"" S LIST(1)="-1^Id is not defined." Q
  1. ;**126 ANY ID IS ALLOWED
  1. ;I TYPE'="NI",TYPE'="PI" S LIST(1)="-1^Invalid Id Type." Q
  1. ;I ASSIGN'="USVHA",ASSIGN'="USDOD" S LIST(1)="-1^Invalid Assigning Authority." Q
  1. I SITE']"" S LIST(1)="-1^Missing Assigning Facility." Q
  1. ; find the ien for the station number
  1. S SITEIEN=$O(^DIC(4,"D",SITE,0))
  1. I 'SITEIEN S LIST(1)="-1^Assigning Facility is not defined in database." Q
  1. ;*1026 ALLOW ANY ID TO BE USED FOR LOOKUP IN TF LIST TO FIND THE FULL ID LIST
  1. I ID["V",TYPE="NI",ASSIGN="USVHA",SITE="200M" S ICN=ID ;ICN is lookup value
  1. S IEN=$O(^DGCN(391.91,"AISS",ID,ASSIGN,TYPE,SITEIEN,0))
  1. ;
  1. ;**1042, VAMPI-8215 (dri) - retrieve tf's from new person tf file (#391.92)
  1. ;if id passed doesn't exist in tf file (#391.91) and the icn (if passed) is not
  1. ;known to the patient file (#2), look in new person tf file (#391.92) for tf's
  1. ;if no list of new person tf's returned continue on to look at #391.91
  1. I IEN=""&($$GETDFN^MPIF001($G(ICN))<0) D I $D(LIST) Q
  1. .N FAC,SOURCEID,IDTYP,AA,IDENSTAT,CTR,NPTFIEN,NPIEN,VAFCARR
  1. .S CTR=1
  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
  1. ..S NPTFIEN=0 F S NPTFIEN=$O(^DGCN(391.92,"B",NPIEN,NPTFIEN)) Q:'NPTFIEN D
  1. ...D GETS^DIQ(391.92,NPTFIEN_",",".02;.03;.04;.05;.06","I","VAFCARR")
  1. ...S FAC=VAFCARR(391.92,NPTFIEN_",",.02,"I")
  1. ...S SOURCEID=VAFCARR(391.92,NPTFIEN_",",.03,"I")
  1. ...S IDTYP=VAFCARR(391.92,NPTFIEN_",",.04,"I")
  1. ...S AA=VAFCARR(391.92,NPTFIEN_",",.05,"I")
  1. ...S IDENSTAT=$S($D(^DGCN(391.919,"ACRNR",FAC)):"C",1:VAFCARR(391.92,NPTFIEN_",",.06,"I"))
  1. ...S LIST(CTR)=SOURCEID_U_IDTYP_U_AA_U_$$STA^XUAF4(FAC)_U_IDENSTAT S CTR=CTR+1
  1. ;
  1. I IEN="",$G(ICN)="" S LIST(1)="-1^Id as '"_ID_"'"_" is not in database" Q
  1. ;
  1. I IEN'="" S DFN=$P(^DGCN(391.91,IEN,0),"^")
  1. I $G(ICN)="" S ICN=$$GETICN^MPIF001(DFN)
  1. I $G(ICN)'="" S DFN=$$GETDFN^MPIF001(ICN)
  1. S X=$$QUERYTF($P($G(ICN),"V"),"LIST")
  1. ;**1026 ANY ID IS ALLOWED, INCLUDING ONE THAT ISN'T THE DFN LOCALLY
  1. ;I TYPE="PI",ASSIGN="USVHA" S DFN=ID
  1. ;I TYPE="NI",ASSIGN="USVHA",SITE="200M" S ICN=ID
  1. ;I TYPE="NI",ASSIGN="USDOD",SITE="200DOD" S EDIPI=ID
  1. ;I $D(ICN) S DFN=$$GETDFN^MPIF001(ICN) D Q:$D(LIST(1))
  1. ;. I +DFN<0 S LIST(1)="-1^ICN is not known" Q
  1. ;. S SITEIEN=$$IEN^XUAF4($P($$SITE^VASITE,"^",3))
  1. ;;
  1. ;I $D(DFN) S ICN=$$GETICN^MPIF001(DFN)
  1. ;; DFN should be defined, but ICN may not.
  1. ;; I $D(EDIPI) S ICN=$$GETICN(EDIPI)
  1. ;; check EDIPI
  1. ;;I $D(EDIPI),'$D(^DGCN(391.91,"ASCR",EDIPI,SITEIEN)) D Q
  1. ;;. S LIST(1)="-1^EDIPI Record is unknown at this facility"
  1. ;;I $D(EDIPI),$D(^DGCN(391.91,"ASCR",EDIPI,SITEIEN)) D
  1. ;;.S EN=$O(^DGCN(391.91,"ASCR",EDIPI,SITEIEN,0))
  1. ;;.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
  1. ;;**856 MVI 1371 (ckn)
  1. ;Use new xref AISS appropriately to retrieve DFN from EDIPI
  1. ;I $D(EDIPI)=""!(ASSIGN="")!(TYPE="")!(SITEIEN="") S LIST(1)="-1^Insufficient data" Q
  1. ;I $D(EDIPI),'$D(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN)) D Q
  1. ;. S LIST(1)="-1^EDIPI Record is unknown at this facility"
  1. ;I $D(EDIPI),$D(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN)) D
  1. ;.S EN=$O(^DGCN(391.91,"AISS",EDIPI,ASSIGN,TYPE,SITEIEN,0))
  1. ;.S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
  1. ;;
  1. ;; if ICN is not defined, it is OK, but DFN should be defined
  1. ;; I $G(ICN)<0 S LIST(1)=ICN Q
  1. ;; bad input, such as Id^NI^USVHA^123
  1. ;I '$G(DFN) S LIST(1)="-1^Invalid input" Q
  1. ;; check DFN and Site to be matching an entry in file #391.91
  1. ;I '$O(^DGCN(391.91,"APAT",DFN,SITEIEN,0)) D Q
  1. ;. S LIST(1)="-1^Id as '"_ID_"'"_" is not in database"
  1. ;; DFN should be defined, but ICN may not.
  1. ;S X=$$QUERYTF($P($G(ICN),"V"),"LIST")
  1. ;I $P(X,U)="1" S LIST(1)="-1"_U_$P(X,U,2) Q
  1. ;S DR=".01;13;99",DIC=4,DIQ(0)="E",DIQ="VAFCTFU2"
  1. ;F VAFC=0:0 S VAFC=$O(LIST(VAFC)) Q:VAFC="" D
  1. ;.K VAFCTFU2
  1. ;.S DA=+LIST(VAFC)
  1. ;.D EN^DIQ1
  1. ;.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)
  1. Q
  1. GETICN(EDIPI) ;return the ICN when EDIPI is passed
  1. N EN,DFN,ICN,IEN
  1. S IEN=$$IEN^XUAF4("200DOD")
  1. I 'IEN Q "-1^Unknown Assigning Facility."
  1. I '$D(^DGCN(391.91,"ASCR",EDIPI,IEN)) Q "-1^EDIPI Record is unknown at this facility"
  1. I $D(^DGCN(391.91,"ASCR",EDIPI,IEN)) D
  1. .S EN=$O(^DGCN(391.91,"ASCR",EDIPI,$$IEN^XUAF4("200DOD"),""))
  1. .S DFN=$P($G(^DGCN(391.91,EN,0)),"^")
  1. .I DFN'="" S ICN=$$GETICN^MPIF001(DFN)
  1. .I DFN="" S ICN="-1^No Site Record associated with this entry"
  1. Q ICN
  1. ;
  1. 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>
  1. N DGCN,INSTIEN,LSTA,SOURCE,EN,NODE,SDFN,STATUS,SITEN,ID,IDTYPE,SITE,ASSAUTH,FOUND,NODE0,NODE2
  1. S DGCN(0)=$G(^DGCN(391.91,TFIEN,0)),SITEN=""
  1. ;** FROM DG*5.3*800 - (ckn) - Quit if IPP field is not set for 200MH record - removed in **863 MVI 2544
  1. S INSTIEN=$P($G(DGCN(0)),"^",2),LSTA=$$STA^XUAF4(INSTIEN)
  1. ;I $E(LSTA,1,5)="200MH",$P($G(DGCN(0)),"^",8)'=1 Q ;include all MHV records MVI 2544 **863
  1. S ID=$P(DGCN(0),"^"),SITE=$P(DGCN(0),"^",2) I SITE'="" S SITEN=$$STA^XUAF4(SITE)
  1. ;S IDTYPE="PI"
  1. ;I SITEN="200DOD"!(SITEN["200N") S IDTYPE="NI"
  1. ;S ASSAUTH="USVHA"
  1. ;I SITEN="200DOD" S ASSAUTH="USDOD"
  1. ; GET SOURCE ID AND SOURCE STATUS - CAN BE MORE THAN ONE
  1. ;^DGCN(391.91,14842,0)=7169806^17942
  1. ;^DGCN(391.91,14842,1,0)=^391.9101A^2^2
  1. ;^DGCN(391.91,14842,1,1,0)=1^A
  1. ;^DGCN(391.91,14842,1,2,0)=2^H
  1. ;^DGCN(391.91,14842,1,"B",1,1)=
  1. ;^DGCN(391.91,14842,1,"B",2,2)=
  1. ;^DGCN(391.91,1708,0)=7169806^500^3081204.152808^^^^1
  1. ;^DGCN(391.91,1708,1,0)=^391.9101A^1^1
  1. ;^DGCN(391.91,1708,1,1,0)=27^H
  1. ;^DGCN(391.91,1708,1,"B",27,1)=
  1. ;**856 - MVI 1371 (ckn)
  1. ;After DG*5.3*837 - TREATING FACILITY LIST file #391.91 does not
  1. ;store Source Id value in SOURCE ID multiple field. This field is
  1. ;is moved to top level. We no longer need to loop through SOURNCE ID
  1. ;multiple to get the values.
  1. ;S SOURCE="",FOUND=0
  1. ;I $D(^DGCN(391.91,TFIEN,1)) D
  1. ;.S EN=0 F S EN=$O(^DGCN(391.91,TFIEN,1,EN)) Q:EN="" D
  1. ;..;S NODE=$G(^DGCN(391.91,TFIEN,1,EN,0))
  1. S NODE0=$G(^DGCN(391.91,TFIEN,0))
  1. S NODE2=$G(^DGCN(391.91,TFIEN,2))
  1. S SDFN=$P(NODE2,"^",2),STATUS=$P(NODE2,"^",3),IDTYPE=$P(NODE0,"^",9)
  1. S ASSAUTH=$P(NODE2,"^")
  1. I SITEN="200DOD"!(SITEN["200N") S IDTYPE="NI"
  1. I SITEN="200DOD" S ASSAUTH="USDOD"
  1. I IDTYPE="" S IDTYPE="PI"
  1. I ASSAUTH="" S ASSAUTH="USVHA"
  1. I SITEN["200N"&(IDTYPE="NI")&(ASSAUTH="USVHA") S ASSAUTH=""
  1. ;S SDFN=$P(NODE,"^"),STATUS=$P(NODE,"^",2)
  1. ;**981, Story 961754 (jfw) - Allow for Status of CERNER if NOT currently MERGED
  1. S:(STATUS'="H") STATUS=$S($D(^DGCN(391.919,"ACRNR",SITEN)):"C",1:STATUS)
  1. I SDFN'="" S CTR=CTR+1,@ARY@(CTR)=SDFN_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN_"^"_STATUS,FOUND=1
  1. ;I FOUND=0 S CTR=CTR+1,@ARY@(CTR)=""_"^"_IDTYPE_"^"_ASSAUTH_"^"_SITEN
  1. Q
  1. ;
  1. QUERYTF(PAT,ARY) ;a query for Treating Facility.
  1. ;INPUT PAT - The patient's ICN
  1. ; ARY - The array in which to return the Treating facility info.
  1. ;OUTPUT A list of the Treating Facilities in the array provided from
  1. ; the parameter. It will be in the structure of x(1), x(2) etc.
  1. ; Ex X(1)=<ID> ^ <ID TYPE> ^ <Assigning Authority> ^ <Assigning Facility> ^ <ID Status>
  1. ;
  1. ; This is also a function call. If there is an error then a
  1. ; 1^error description will be returned.
  1. ;
  1. ; *** If no data is found the array will not be populated and
  1. ; a 1^error description will be returned.
  1. ;
  1. N PDFN,VAFCER,LP,CTR
  1. ;
  1. ; ICN is not required, comment out
  1. ; I '$G(PAT)!('$D(ARY)) S VAFCER="1^Parameter missing." G QUERYTFQ
  1. I ('$D(ARY)) S VAFCER="1^Parameter missing." G QUERYTFQ
  1. S VAFCER=0,CTR=1
  1. S X="MPIF001" X ^%ZOSF("TEST") I '$T G QUERYTFQ
  1. ; ICN is not required, comment out
  1. ; S PDFN=$$GETDFN^MPIF001(PAT)
  1. ; I PDFN<0 S VAFCER="1^No patient DFN." G QUERYTFQ
  1. S PDFN=$G(DFN)
  1. I '$G(PDFN) S VAFCER="1^DFN is not defined." G QUERYTFQ
  1. ;SET FIRST ENTRY TO BE THE ICN - FULL ICN - PAT IS NOT THE ICN
  1. S @ARY@(CTR)=$$GETICN^MPIF001(PDFN)_"^NI^USVHA^200M^A"
  1. ;**856 - MVI 1371 (ckn)
  1. ;Loop through all TFIENs for site
  1. ;F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP S TFIEN=$O(^(LP,"")) D SET(TFIEN,ARY,.CTR)
  1. F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP D
  1. .S TFIEN=0 F S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,LP,TFIEN)) Q:'TFIEN D
  1. ..D SET(TFIEN,ARY,.CTR)
  1. I $D(@ARY)'>9 S VAFCER="1^Could not find Treating Facilities"
  1. QUERYTFQ Q VAFCER
  1. ;
  1. NEWTF(RESULT,DFN,EDIPI) ;
  1. ; for MPIC_2019
  1. ; called from RPC: VAFC NEW NC TREATING FACILITY
  1. ; Input:
  1. ; DFN: Vista Patient Identifier will be the PATIENT file (#2) IEN (aka DFN)
  1. ; example of DFN="7168937"
  1. ;
  1. ; EDIPI: The DOD Identifier will be EDIPI data with the
  1. ; following format:
  1. ; Id^IdType^AssigningAuthority^AssigningFacility
  1. ; example: 852043888^NI^USDOD^200DOD
  1. ;
  1. ; Return:
  1. ; This will return a list of treating facilities in the following.
  1. ;
  1. ; format:
  1. ; Id^IdType^AssigningAuthority^AssigningFacility^IdStatus[^NEW]
  1. ;
  1. ; Examples:
  1. ; RESULT(1)="7168937^PI^USVHA^500^A"
  1. ; RESULT(2)="85204388^NI^USDOD^200DOD^A^NEW"
  1. ; Note: If there is data in the 6th piece of the RESULT(<number>),
  1. ; with data value as "NEW", then it means that the entry was
  1. ; newly created in the TREATING FACILITY LIST (#391.91) file
  1. ; by this RPC call.
  1. ;
  1. N X,TYPE,SITE,ID,ASSIGN,PTDFN,LP,CTR,NCTFIEN,ERROR,II
  1. S X="MPIF001" X ^%ZOSF("TEST") I '$T S RESULT(1)="-1^MPI Not Installed" Q
  1. ; clear "return" variable
  1. K RESULT
  1. ; input parameters
  1. S PTDFN=$G(DFN)
  1. I 'PTDFN S RESULT(1)="-1^Invalid DFN:"""_PTDFN_"""" Q
  1. ; check the field #.01 data in patient entry
  1. I $P($G(^DPT(PTDFN,0)),"^")']"" D Q
  1. . S RESULT(1)="-1^No patient in database for the DFN:"_PTDFN
  1. ;
  1. S ID=$P(EDIPI,"^"),TYPE=$P(EDIPI,"^",2),ASSIGN=$P(EDIPI,"^",3)
  1. S SITE=$P(EDIPI,"^",4)
  1. ;
  1. I ID']"" S RESULT(1)="-1^Id is not defined." Q
  1. I TYPE'="NI" S RESULT(1)="-1^Invalid Id Type." Q
  1. I ASSIGN'="USDOD" S RESULT(1)="-1^Invalid Assigning Authority." Q
  1. I SITE'="200DOD" S RESULT(1)="-1^Invalid Assigning Facility." Q
  1. S SITEIEN=$O(^DIC(4,"D","200DOD",0))
  1. I 'SITEIEN S RESULT(1)="-1^Assigning Facility is not defined in database." Q
  1. ;
  1. ; get ien of file #391.91
  1. S NCTFIEN=$O(^DGCN(391.91,"APAT",PTDFN,SITEIEN,0))
  1. ;
  1. ; Assigning Facility as "200DOD" of the patient is already existed
  1. ; in file #391.91
  1. S CTR=0
  1. I NCTFIEN D Q
  1. . N TFIEN
  1. . F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PTDFN,LP)) Q:'LP S TFIEN=$O(^(LP,0)) D
  1. .. Q:'TFIEN
  1. .. ; retrieve entry in file #391.91
  1. .. D SET(TFIEN,"RESULT",.CTR)
  1. ;
  1. ; add new entry to file #391.91
  1. D FILENEW^VAFCTFU(PTDFN,SITEIEN,"","","",.ERROR,"",ID,"A")
  1. I $D(ERROR(SITEIEN)) D Q
  1. . S RESULT(1)="-1^"_$G(ERROR(SITEIEN))
  1. ;
  1. ; for Cache client/server model in case that there is a delay for
  1. ; retrieving the new created entry.
  1. F II=1:1:5 Q:$O(^DGCN(391.91,"APAT",PTDFN,SITEIEN,0)) H II
  1. ; retrieving the results
  1. F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PTDFN,LP)) Q:'LP S TFIEN=$O(^(LP,0)) D
  1. . Q:'TFIEN
  1. . ; retrieve entry in file #391.91
  1. . D SET(TFIEN,"RESULT",.CTR)
  1. . I $P($G(RESULT(CTR)),"^",3)="USDOD" S RESULT(CTR)=RESULT(CTR)_"^NEW"
  1. Q
  1. ;