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-Utilities for the Treating Facility file 391.91, CONTINUED ; 4/21/2010
  1.  ;;5.3;PIMS;**1016**;JUN 30, 2012;Build 20
  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
  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.  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.  ;
  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.  ;
  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
  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
  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
  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.  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 SDFN=$P(NODE,"^"),STATUS=$P(NODE,"^",2)
  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.  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.  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.  ;