VAFCTFU1 ;BHM/RGY-Utilities for the Treating Facility file 391.91, CONTINUED ;6 May 2021 1:56 PM
;;5.3;Registration;**261,392,448,449,800,856,1042,1055**;Aug 13, 1993;Build 1
TFL(LIST,DFN) ;for dfn get list of treating facilities
NEW X,ICN,DA,DR,VAFCTFU1,DIC,DIQ,VAFC
S X="MPIF001" X ^%ZOSF("TEST") I '$T S LIST(1)="-1^MPI Not Installed" Q
S DR=".01;13;99",DIC=4,DIQ(0)="E",DIQ="VAFCTFU1" ;**448
S ICN=$$GETICN^MPIF001(DFN)
I ICN<0 S LIST(1)=ICN Q
S X=$$QUERYTF($P(ICN,"V"),"LIST",0)
I $P(X,U)="1" S LIST(1)="-1"_U_$P(X,U,2) Q
F VAFC=0:0 S VAFC=$O(LIST(VAFC)) Q:VAFC="" D
.K VAFCTFU1
.S DA=+LIST(VAFC)
.D EN^DIQ1
.S LIST(VAFC)=VAFCTFU1(4,+LIST(VAFC),99,"E")_"^"_VAFCTFU1(4,+LIST(VAFC),.01,"E")_"^"_$P(LIST(VAFC),"^",2)_"^"_$P(LIST(VAFC),"^",3)_"^"_VAFCTFU1(4,+LIST(VAFC),13,"E") ;**448
.Q
Q
GETICN(RESULT,DFN) ;
S RESULT=$$GETICN^MPIF001(DFN)
Q
GETDFN(RESULT,ICN) ;
S RESULT=$$GETDFN^MPIF001(ICN)
Q
IFLOCAL(RESULT,DFN) ;
S RESULT=$$IFLOCAL^MPIF001(DFN)
Q
;
SET(TFIEN,ARY,CTR) ;This sets the array with the treating facility list.
; Returns: treating facility ^ treatment date ^ event reason (if any)
; *261 gjc@120899 (formerly part of VAFCTFU prior to DG*5.3*261)
N DGCN,INSTIEN,LSTA S DGCN(0)=$G(^DGCN(391.91,TFIEN,0))
;** 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 CTR=CTR+1,@ARY@(CTR)=$P(DGCN(0),U,2,3)_U_$P(DGCN(0),U,7)
Q
;
QUERYTF(PAT,ARY,INDX) ;a query for Treating Facility.
;INPUT PAT - The patient's ICN
; ARY - The array in which to return the Treating facility info.
; INDX (optional) - the index to $O through. APAT for patient
; information linked to treating facilities, AEVN for patient
; info linked with an event reason. INDX=1 if AEVN is used,
; else APAT is used. *261 gjc@120399
;
;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)=500^2960101^ptr to ADT/HL7 Event Reason file (if exists)
; Where the first piece is the IEN of the institution, the second
; piece is the current date on record for that institution and the
; third piece is the event reason (if it exists). Note: A04 & A08
; events do not file an event reason when adding to the TREATING
; FACILITY LIST (#391.91) file, thus returning null in the third
; piece. *261 gjc@120199
;
; 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,ZTFIEN,ZDLT,ZTDLT
I '$G(PAT)!('$D(ARY)) S VAFCER="1^Parameter missing." G QUERYTFQ
S VAFCER=0,CTR=0,INDX=$G(INDX)
S X="MPIF001" X ^%ZOSF("TEST") I '$T G QUERYTFQ
S PDFN=$$GETDFN^MPIF001(PAT)
I PDFN<0 S VAFCER="1^No patient DFN." G QUERYTFQ
; determine the index to $O through, based on the value of INDX
;I 'INDX F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP S TFIEN=$O(^(LP,"")) D SET(TFIEN,ARY,.CTR)
;**856 - MVI 1371 (ckn)
;Now that Treating Facility file can have multiple entries for
;one site, enhanced the code to loop through all TFIENs for each SITE
;and return the record which have latest Date Last Treated. If none
;of the entries have DLT populated, return the first record for site.
I 'INDX F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP D
.Q:'$$ISVAMC(LP) ;**1042,VAMPI-8212 (mko): Skip non-VAMCs
.S ZTDLT=0,ZTFIEN=$O(^DGCN(391.91,"APAT",PDFN,LP,"")) Q:'ZTFIEN
.S TFIEN=0 F S TFIEN=$O(^DGCN(391.91,"APAT",PDFN,LP,TFIEN)) Q:'TFIEN D
..Q:'$$ISPATIEN(TFIEN) ;**1042,VAMPI-8212 (mko): Skip if not a patient record (not "PI" or null)
..S ZDLT=$P(^DGCN(391.91,TFIEN,0),"^",3) ;Date last treated
..I ZDLT>ZTDLT S ZTDLT=ZDLT,ZTFIEN=TFIEN
.D SET(ZTFIEN,ARY,.CTR)
I INDX S LP=0 F S LP=$O(^DGCN(391.91,"AEVN",PDFN,LP)) Q:'LP D
.; please note the following: the AEVN xref is subscripted by pat. dfn
.; event reason ptr, and the ien of the TFL file. It is possible
.; that a patient may have numerous admission/discharges at different
.; treating facilities, thus the looping through the TFIEN (TFL ien)
.; subscript. *261 gjc@120399
.S TFIEN=0 F S TFIEN=$O(^DGCN(391.91,"AEVN",PDFN,LP,TFIEN)) Q:'TFIEN D SET(TFIEN,ARY,.CTR)
.Q
I $D(@ARY)'>9 S VAFCER="1^Could not find Treating Facilities"
QUERYTFQ Q VAFCER
;
ISVAMC(SITEIEN,SITEID) ;Return 1 if this is a VAMC
;**1042,VAMPI-8212 (mko): New function
N DIERR,MSG
I $G(SITEIEN)="" Q:$G(SITEID)="" "" S SITEIEN=$$IEN^XUAF4(SITEID)
I $G(SITEID)="" S SITEID=$$STA^XUAF4(SITEIEN)
;**1055,VAMPI-10191 (mko): Allow return of 200, 200CH, and 200MH
I "^200CH^200MH^"[(U_SITEID_U) Q 1
I $$GET1^DIQ(4,SITEIEN_",",13,"","","MSG")'="OTHER",SITEID'="200M" Q 1
Q 0
;
ISPATIEN(TFLIEN) ;Return 1 if Source ID Type is "PI" or null
;**1042,VAMPI-8212 (mko): New function
Q:$D(^DGCN(391.91,+$G(TFLIEN),0))[0 0
Q "PI"[$P(^DGCN(391.91,+$G(TFLIEN),0),"^",9)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVAFCTFU1 5215 printed Dec 13, 2024@03:02:30 Page 2
VAFCTFU1 ;BHM/RGY-Utilities for the Treating Facility file 391.91, CONTINUED ;6 May 2021 1:56 PM
+1 ;;5.3;Registration;**261,392,448,449,800,856,1042,1055**;Aug 13, 1993;Build 1
TFL(LIST,DFN) ;for dfn get list of treating facilities
+1 NEW X,ICN,DA,DR,VAFCTFU1,DIC,DIQ,VAFC
+2 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
SET LIST(1)="-1^MPI Not Installed"
QUIT
+3 ;**448
SET DR=".01;13;99"
SET DIC=4
SET DIQ(0)="E"
SET DIQ="VAFCTFU1"
+4 SET ICN=$$GETICN^MPIF001(DFN)
+5 IF ICN<0
SET LIST(1)=ICN
QUIT
+6 SET X=$$QUERYTF($PIECE(ICN,"V"),"LIST",0)
+7 IF $PIECE(X,U)="1"
SET LIST(1)="-1"_U_$PIECE(X,U,2)
QUIT
+8 FOR VAFC=0:0
SET VAFC=$ORDER(LIST(VAFC))
if VAFC=""
QUIT
Begin DoDot:1
+9 KILL VAFCTFU1
+10 SET DA=+LIST(VAFC)
+11 DO EN^DIQ1
+12 ;**448
SET LIST(VAFC)=VAFCTFU1(4,+LIST(VAFC),99,"E")_"^"_VAFCTFU1(4,+LIST(VAFC),.01,"E")_"^"_$PIECE(LIST(VAFC),"^",2)_"^"_$PIECE(LIST(VAFC),"^",3)_"^"_VAFCTFU1(4,+LIST(VAFC),13,"E")
+13 QUIT
End DoDot:1
+14 QUIT
GETICN(RESULT,DFN) ;
+1 SET RESULT=$$GETICN^MPIF001(DFN)
+2 QUIT
GETDFN(RESULT,ICN) ;
+1 SET RESULT=$$GETDFN^MPIF001(ICN)
+2 QUIT
IFLOCAL(RESULT,DFN) ;
+1 SET RESULT=$$IFLOCAL^MPIF001(DFN)
+2 QUIT
+3 ;
SET(TFIEN,ARY,CTR) ;This sets the array with the treating facility list.
+1 ; Returns: treating facility ^ treatment date ^ event reason (if any)
+2 ; *261 gjc@120899 (formerly part of VAFCTFU prior to DG*5.3*261)
+3 NEW DGCN,INSTIEN,LSTA
SET DGCN(0)=$GET(^DGCN(391.91,TFIEN,0))
+4 ;** 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 CTR=CTR+1
SET @ARY@(CTR)=$PIECE(DGCN(0),U,2,3)_U_$PIECE(DGCN(0),U,7)
+8 QUIT
+9 ;
QUERYTF(PAT,ARY,INDX) ;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 ; INDX (optional) - the index to $O through. APAT for patient
+4 ; information linked to treating facilities, AEVN for patient
+5 ; info linked with an event reason. INDX=1 if AEVN is used,
+6 ; else APAT is used. *261 gjc@120399
+7 ;
+8 ;OUTPUT A list of the Treating Facilities in the array provided from
+9 ; the parameter. It will be in the structure of x(1), x(2) etc.
+10 ; Ex X(1)=500^2960101^ptr to ADT/HL7 Event Reason file (if exists)
+11 ; Where the first piece is the IEN of the institution, the second
+12 ; piece is the current date on record for that institution and the
+13 ; third piece is the event reason (if it exists). Note: A04 & A08
+14 ; events do not file an event reason when adding to the TREATING
+15 ; FACILITY LIST (#391.91) file, thus returning null in the third
+16 ; piece. *261 gjc@120199
+17 ;
+18 ; This is also a function call. If there is an error then a
+19 ; 1^error description will be returned.
+20 ;
+21 ; *** If no data is found the array will not be populated and
+22 ; a 1^error description will be returned.
+23 ;
+24 NEW PDFN,VAFCER,LP,CTR,ZTFIEN,ZDLT,ZTDLT
+25 IF '$GET(PAT)!('$DATA(ARY))
SET VAFCER="1^Parameter missing."
GOTO QUERYTFQ
+26 SET VAFCER=0
SET CTR=0
SET INDX=$GET(INDX)
+27 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF '$TEST
GOTO QUERYTFQ
+28 SET PDFN=$$GETDFN^MPIF001(PAT)
+29 IF PDFN<0
SET VAFCER="1^No patient DFN."
GOTO QUERYTFQ
+30 ; determine the index to $O through, based on the value of INDX
+31 ;I 'INDX F LP=0:0 S LP=$O(^DGCN(391.91,"APAT",PDFN,LP)) Q:'LP S TFIEN=$O(^(LP,"")) D SET(TFIEN,ARY,.CTR)
+32 ;**856 - MVI 1371 (ckn)
+33 ;Now that Treating Facility file can have multiple entries for
+34 ;one site, enhanced the code to loop through all TFIENs for each SITE
+35 ;and return the record which have latest Date Last Treated. If none
+36 ;of the entries have DLT populated, return the first record for site.
+37 IF 'INDX
FOR LP=0:0
SET LP=$ORDER(^DGCN(391.91,"APAT",PDFN,LP))
if 'LP
QUIT
Begin DoDot:1
+38 ;**1042,VAMPI-8212 (mko): Skip non-VAMCs
if '$$ISVAMC(LP)
QUIT
+39 SET ZTDLT=0
SET ZTFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,LP,""))
if 'ZTFIEN
QUIT
+40 SET TFIEN=0
FOR
SET TFIEN=$ORDER(^DGCN(391.91,"APAT",PDFN,LP,TFIEN))
if 'TFIEN
QUIT
Begin DoDot:2
+41 ;**1042,VAMPI-8212 (mko): Skip if not a patient record (not "PI" or null)
if '$$ISPATIEN(TFIEN)
QUIT
+42 ;Date last treated
SET ZDLT=$PIECE(^DGCN(391.91,TFIEN,0),"^",3)
+43 IF ZDLT>ZTDLT
SET ZTDLT=ZDLT
SET ZTFIEN=TFIEN
End DoDot:2
+44 DO SET(ZTFIEN,ARY,.CTR)
End DoDot:1
+45 IF INDX
SET LP=0
FOR
SET LP=$ORDER(^DGCN(391.91,"AEVN",PDFN,LP))
if 'LP
QUIT
Begin DoDot:1
+46 ; please note the following: the AEVN xref is subscripted by pat. dfn
+47 ; event reason ptr, and the ien of the TFL file. It is possible
+48 ; that a patient may have numerous admission/discharges at different
+49 ; treating facilities, thus the looping through the TFIEN (TFL ien)
+50 ; subscript. *261 gjc@120399
+51 SET TFIEN=0
FOR
SET TFIEN=$ORDER(^DGCN(391.91,"AEVN",PDFN,LP,TFIEN))
if 'TFIEN
QUIT
DO SET(TFIEN,ARY,.CTR)
+52 QUIT
End DoDot:1
+53 IF $DATA(@ARY)'>9
SET VAFCER="1^Could not find Treating Facilities"
QUERYTFQ QUIT VAFCER
+1 ;
ISVAMC(SITEIEN,SITEID) ;Return 1 if this is a VAMC
+1 ;**1042,VAMPI-8212 (mko): New function
+2 NEW DIERR,MSG
+3 IF $GET(SITEIEN)=""
if $GET(SITEID)=""
QUIT ""
SET SITEIEN=$$IEN^XUAF4(SITEID)
+4 IF $GET(SITEID)=""
SET SITEID=$$STA^XUAF4(SITEIEN)
+5 ;**1055,VAMPI-10191 (mko): Allow return of 200, 200CH, and 200MH
+6 IF "^200CH^200MH^"[(U_SITEID_U)
QUIT 1
+7 IF $$GET1^DIQ(4,SITEIEN_",",13,"","","MSG")'="OTHER"
IF SITEID'="200M"
QUIT 1
+8 QUIT 0
+9 ;
ISPATIEN(TFLIEN) ;Return 1 if Source ID Type is "PI" or null
+1 ;**1042,VAMPI-8212 (mko): New function
+2 if $DATA(^DGCN(391.91,+$GET(TFLIEN),0))[0
QUIT 0
+3 QUIT "PI"[$PIECE(^DGCN(391.91,+$GET(TFLIEN),0),"^",9)
