- 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 Jan 18, 2025@04:03:11 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)