- DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 2/12/2020
- ;;5.3;Registration;**425,554,650,1005,1028,1054,1069**;Aug 13, 1993;Build 3
- ;
- ; This routine contains generic calls for use throughout DGPF*.
- ;
- ;- no direct entry
- QUIT
- ;
- ;
- GETPAT(DGDFN,DGPAT) ;retrieve patient identifying information
- ; Used to obtain identifying information for a patient
- ; in the PATIENT (#2) file and place it in an array format.
- ;
- ; NOTE: Direct global reference of patient's zero node in the
- ; PATIENT (#2) file is supported by DBIA #10035
- ;
- ; Input:
- ; DGDFN - (required) ien of patient in PATIENT (#2) file
- ;
- ; Output:
- ; Function Value - returns 1 on success, 0 on failure
- ; DGPAT - output array containing the patient identifying information,
- ; on success, pass by reference.
- ; Array subscripts are:
- ; "DFN" - ien PATIENT (#2) file
- ; "NAME" - patient name
- ; "SSN" - patient Social Security Number
- ; "DOB" - patient date of birth (FM format)
- ; "SEX" - patient sex
- ;
- N DGNODE
- N RESULT
- ;
- S RESULT=0
- ;
- I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D
- .
- . ;-- obtain zero node of patient record (supported by DBIA #10035)
- . S DGNODE=$G(^DPT(DGDFN,0))
- . ;
- . S DGPAT("DFN")=DGDFN
- . S DGPAT("NAME")=$P(DGNODE,"^")
- . S DGPAT("SEX")=$P(DGNODE,"^",2)
- . S DGPAT("DOB")=$P(DGNODE,"^",3)
- . S DGPAT("SSN")=$P(DGNODE,"^",9)
- . S RESULT=1 ;success
- ;
- Q RESULT
- ;
- GETDFN(DGICN,DGEROOT) ;Used to convert an ICN to a DFN.
- ;
- ; Supported DBIA #2701: The supported DBIA is used to retrieve the
- ; pointer (DFN) to the PATIENT (#2) file for a
- ; given ICN.
- ;
- ; Input:
- ; DGICN - Integrated Control Number with or without checksum
- ; DGEROOT - (optional) closed root array name (i.e. "DGERROR") for
- ; error dialog returned from BLD^DIALOG. If not passed,
- ; error dialog is returned in ^TMP("DIERR",$J) global.
- ;
- ; Output:
- ; Function Value - DFN on success, 0 on failure
- ; DGEROOT() - error output array from BLD^DIALOG
- ;
- N DGDFN ;ptr to patient
- N DIERR ;var returned from BLD^DIALOG
- ;
- ;init error output array if passed
- S DGEROOT=$G(DGEROOT)
- I DGEROOT]"" K @DGEROOT
- ;
- S DGDFN=+$$GETDFN^MPIF001(+$G(DGICN))
- I DGDFN'>0 D BLD^DIALOG(261127,,,DGEROOT,"F")
- ;
- Q $S(DGDFN'>0:0,1:DGDFN)
- ;
- SORT(DGPFARR) ;Re-sort of active record assignments by category then flag name
- ; This function re-sorts the active record flag assignment list for a
- ; patient by category (Cat I or Cat II) and then by flag name.
- ;
- ; Input: [Required]
- ; DGPFARR - Closed root reference array name of active assignments
- ; to be sorted
- ;
- ; Output:
- ; Function Value - returns 1 on success, 0 on failure
- ;
- ; DGPFARR() - Closed Root reference name of re-sorted assignments
- ; - Category I's will sort first in the returned array.
- ; - Category II's will sort second.
- ;
- N DGCAT ;category
- N DGINDX ;index array
- N DGNAME ;flag name
- N DGSORT ;re-sorted data array
- N DGX ;generic counter
- ;
- ; check for input value - Quit if none found
- Q:DGPFARR']"" 0
- Q:'$O(@DGPFARR@("")) 0
- ;
- S DGSORT=$NA(^TMP("DGPFUT2",$J))
- K @DGSORT
- ;
- ;build index - ARRAY(Category (I or II),Flag Name)=sort number
- S DGX=0
- F S DGX=$O(@DGPFARR@(DGX)) Q:'DGX D
- . S DGCAT=$S($P(@DGPFARR@(DGX,"FLAG"),U)[26.11:2,1:1)
- . S DGINDX(DGCAT,$P(@DGPFARR@(DGX,"FLAG"),U,2))=DGX
- ;
- ;build sorted data array -
- S (DGCAT,DGX)=0
- F S DGCAT=$O(DGINDX(DGCAT)) Q:'DGCAT D
- . S DGNAME=""
- . F S DGNAME=$O(DGINDX(DGCAT,DGNAME)) Q:DGNAME="" D
- . . S DGX=DGX+1
- . . M @DGSORT@(DGX)=@DGPFARR@(DGINDX(DGCAT,DGNAME))
- ;
- ;remove input array and replace with sorted array, kill sort array
- K @DGPFARR
- M @DGPFARR=@DGSORT
- K @DGSORT
- ;
- Q 1
- ;
- ACTDT ; update PRF Software Activation Date field in (#26.18)
- ; This utility should only be run at the Alpha and Beta test sites
- ; of the Patient Record Flags Project, Patch DG*5.3*425.
- ; If necessary, this entry point will change the date that the
- ; Patient Record Flags (PRF) System became active.
- ; The (#1) PRF SOFTWARE ACTIVATION DATE field of the (#26.18) PRF
- ; PARAMETERS file, will be changed to: SEP 25, 2003
- ;
- ; Input: none
- ;
- ; Output: User message on successful or failure of file update
- ;
- N DGACTDT ; Nationally Released Software Activation Date value
- N DGIENS ; IEN - internal entry # OF (#26.18) FILE
- N DGFLD ; PRF Software Activation Date field #
- N DGFDA ; FDA data array for filer
- N DGERR ; error message array returned from filer
- N DGERRMSG ; error message for display
- N DGPARM ; current internal/external values of field
- ;
- S DGACTDT="SEP 25, 2003"
- S DGIENS="1,"
- S DGFLD=1
- ;
- ; display user message
- W !!,"Updating the PRF SOFTWARE ACTIVATION DATE (#1) field in the PRF PARAMETERS FILE (#26.18) to the value of SEP 25, 2003..."
- ;
- ; checks for necessary programmer variables
- I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
- . S DGERRMSG="Your programming variables are not set up properly."
- ;
- ; check if activation is not less than the current date
- I '$D(DGERRMSG),DT<3030925 D
- . S DGERRMSG="This file/field update can't be run before the date of SEP 25, 2003 is reached."
- ;
- ; get current activation date from PRF PARAMETERS (#26.18) file
- I '$D(DGERRMSG) D
- . D GETS^DIQ(26.18,"1,",1,"IE","DGPARM","DGERR")
- . ;
- . ; check for errors and inform the user
- . I $D(DGERR) D Q
- . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1))
- . ;
- . ; check to make sure field is not set already
- . I $G(DGPARM(26.18,"1,",1,"I"))=3030925 D
- . . S DGERRMSG="The date value is already set to SEP 25, 2003."
- ;
- ; now start the (#26.18) filing process
- I '$D(DGERRMSG) D
- . ;
- . ; DELETE activation date before filing since field is uneditable
- . S DGFDA(26.18,DGIENS,1)="@"
- . D FILE^DIE("","DGFDA","DGERR")
- . ;
- . ; check for errors and inform the user
- . I $D(DGERR) D Q
- . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1))
- . ;
- . ; setup and file the new activation date value (external)
- . S DGFDA(26.18,DGIENS,1)=DGACTDT
- . D FILE^DIE("SE","DGFDA","DGERR")
- . ;
- . ; check for success or errors and inform the user of update status
- . I $D(DGERR) D Q
- . . S DGERRMSG=$G(DGERR("DIERR",1,"TEXT",1))
- ;
- ; display successful/failure file update - updated field and value
- W !!,$C(7)
- I $D(DGERRMSG) D
- . W "Field could not be updated...",DGERRMSG
- E D
- . W "Field was successfully changed from ",$G(DGPARM(26.18,"1,",1,"E"))," to ",$G(DGFDA(26.18,DGIENS,DGFLD)),"."
- ;
- Q
- ;
- ;
- BLDTFL(DGDFN,DGTFL) ;build array of Treating Facilities
- ; This function builds an array of INSTITUTION (#4) file pointers
- ; that are non-local medical treating facilities for a given patient.
- ;
- ; Input:
- ; DGDFN - pointer to patient in PATIENT (#2) file
- ;
- ; Output:
- ; Function value - 1 on results returned; 0 on failure
- ; DGTFL - array of treating facility INSTITUTION (#4) file pointerS
- ; Format: DGTFL(pointer)=date last treated
- N DGSTAT,DGSTATI,DGKEY,DGOUT,DGI,DGSTI,DGIEN,DGDLT
- S DGSTAT=$P($$SITE^VASITE,U,3)
- S DGSTATI=$P($$SITE^VASITE,U)
- S DGKEY=DGDFN_U_"PI"_U_"USVHA"_U_DGSTAT
- D TFL^VAFCTFU2(.DGOUT,DGKEY)
- S DGI="" F S DGI=$O(DGOUT(DGI)) Q:DGI="" D
- . I $P(DGOUT(DGI),U,2)="PI",$P(DGOUT(DGI),U,3)="USVHA" D
- . . I $P(DGOUT(DGI),U,4)="200CRNR" D
- . . . S DGSTI=$$IEN^XUAF4($P(DGOUT(DGI),U,4))
- . . . S DGIEN=$O(^DGCN(391.91,"AINST",DGSTI,DGDFN,""))
- . . . Q:DGIEN=""
- . . . S DGDLT=+$P($G(^DGCN(391.91,DGIEN,0)),U,3)
- . . . S DGTFL(DGSTI)=DGDLT
- . . . Q
- . . S DGSTI=$$IEN^XUAF4($P(DGOUT(DGI),U,4))
- . . ;Q:DGSTI=""
- . . Q:$$GET1^DIQ(4,DGSTI_",",13)="OTHER"!(+$$STA^XUAF4(DGSTI)=200)!(DGSTI=DGSTATI)
- . . S DGIEN=$O(^DGCN(391.91,"AINST",DGSTI,DGDFN,""))
- . . Q:DGIEN=""
- . . S DGDLT=+$P($G(^DGCN(391.91,DGIEN,0)),U,3)
- . . S DGTFL(DGSTI)=DGDLT ;DG*5.3*1054 only setting entries that are VistAs and PI/USHVA records
- . .; S:DGSTI'=DGSTATI DGTFL(DGSTI)=DGDLT
- Q $S(+$O(DGTFL(0)):1,1:0)
- ;
- ;This subroutine converts the treating facility list returned by $$BLDTFL to
- ;the format expected by XMIT^DGPFHLU6.
- ;
- ;Input:
- ; DGDFN - pointer to the patient in the PATIENT (#2) file
- ;Output:
- ; DGTFL - array in the format DGTFL(#)=station number (not pointer)
- BLDTFL2(DGDFN,DGTFL) ;
- N DGI,DGJ,DGTMP,DGRET
- S DGRET=$$BLDTFL(DGDFN,.DGTMP)
- S DGJ=0
- S DGI="" F S DGI=$O(DGTMP(DGI)) Q:DGI="" D
- . S DGJ=DGJ+1
- . S DGTFL(DGJ)=$$STA^XUAF4(DGI)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFUT2 8694 printed Jan 18, 2025@03:49:31 Page 2
- DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 2/12/2020
- +1 ;;5.3;Registration;**425,554,650,1005,1028,1054,1069**;Aug 13, 1993;Build 3
- +2 ;
- +3 ; This routine contains generic calls for use throughout DGPF*.
- +4 ;
- +5 ;- no direct entry
- +6 QUIT
- +7 ;
- +8 ;
- GETPAT(DGDFN,DGPAT) ;retrieve patient identifying information
- +1 ; Used to obtain identifying information for a patient
- +2 ; in the PATIENT (#2) file and place it in an array format.
- +3 ;
- +4 ; NOTE: Direct global reference of patient's zero node in the
- +5 ; PATIENT (#2) file is supported by DBIA #10035
- +6 ;
- +7 ; Input:
- +8 ; DGDFN - (required) ien of patient in PATIENT (#2) file
- +9 ;
- +10 ; Output:
- +11 ; Function Value - returns 1 on success, 0 on failure
- +12 ; DGPAT - output array containing the patient identifying information,
- +13 ; on success, pass by reference.
- +14 ; Array subscripts are:
- +15 ; "DFN" - ien PATIENT (#2) file
- +16 ; "NAME" - patient name
- +17 ; "SSN" - patient Social Security Number
- +18 ; "DOB" - patient date of birth (FM format)
- +19 ; "SEX" - patient sex
- +20 ;
- +21 NEW DGNODE
- +22 NEW RESULT
- +23 ;
- +24 SET RESULT=0
- +25 ;
- +26 IF $GET(DGDFN)>0
- IF $DATA(^DPT(DGDFN,0))
- Begin DoDot:1
- +27 +28 ;-- obtain zero node of patient record (supported by DBIA #10035)
- +29 SET DGNODE=$GET(^DPT(DGDFN,0))
- +30 ;
- +31 SET DGPAT("DFN")=DGDFN
- +32 SET DGPAT("NAME")=$PIECE(DGNODE,"^")
- +33 SET DGPAT("SEX")=$PIECE(DGNODE,"^",2)
- +34 SET DGPAT("DOB")=$PIECE(DGNODE,"^",3)
- +35 SET DGPAT("SSN")=$PIECE(DGNODE,"^",9)
- +36 ;success
- SET RESULT=1
- End DoDot:1
- +37 ;
- +38 QUIT RESULT
- +39 ;
- GETDFN(DGICN,DGEROOT) ;Used to convert an ICN to a DFN.
- +1 ;
- +2 ; Supported DBIA #2701: The supported DBIA is used to retrieve the
- +3 ; pointer (DFN) to the PATIENT (#2) file for a
- +4 ; given ICN.
- +5 ;
- +6 ; Input:
- +7 ; DGICN - Integrated Control Number with or without checksum
- +8 ; DGEROOT - (optional) closed root array name (i.e. "DGERROR") for
- +9 ; error dialog returned from BLD^DIALOG. If not passed,
- +10 ; error dialog is returned in ^TMP("DIERR",$J) global.
- +11 ;
- +12 ; Output:
- +13 ; Function Value - DFN on success, 0 on failure
- +14 ; DGEROOT() - error output array from BLD^DIALOG
- +15 ;
- +16 ;ptr to patient
- NEW DGDFN
- +17 ;var returned from BLD^DIALOG
- NEW DIERR
- +18 ;
- +19 ;init error output array if passed
- +20 SET DGEROOT=$GET(DGEROOT)
- +21 IF DGEROOT]""
- KILL @DGEROOT
- +22 ;
- +23 SET DGDFN=+$$GETDFN^MPIF001(+$GET(DGICN))
- +24 IF DGDFN'>0
- DO BLD^DIALOG(261127,,,DGEROOT,"F")
- +25 ;
- +26 QUIT $SELECT(DGDFN'>0:0,1:DGDFN)
- +27 ;
- SORT(DGPFARR) ;Re-sort of active record assignments by category then flag name
- +1 ; This function re-sorts the active record flag assignment list for a
- +2 ; patient by category (Cat I or Cat II) and then by flag name.
- +3 ;
- +4 ; Input: [Required]
- +5 ; DGPFARR - Closed root reference array name of active assignments
- +6 ; to be sorted
- +7 ;
- +8 ; Output:
- +9 ; Function Value - returns 1 on success, 0 on failure
- +10 ;
- +11 ; DGPFARR() - Closed Root reference name of re-sorted assignments
- +12 ; - Category I's will sort first in the returned array.
- +13 ; - Category II's will sort second.
- +14 ;
- +15 ;category
- NEW DGCAT
- +16 ;index array
- NEW DGINDX
- +17 ;flag name
- NEW DGNAME
- +18 ;re-sorted data array
- NEW DGSORT
- +19 ;generic counter
- NEW DGX
- +20 ;
- +21 ; check for input value - Quit if none found
- +22 if DGPFARR']""
- QUIT 0
- +23 if '$ORDER(@DGPFARR@(""))
- QUIT 0
- +24 ;
- +25 SET DGSORT=$NAME(^TMP("DGPFUT2",$JOB))
- +26 KILL @DGSORT
- +27 ;
- +28 ;build index - ARRAY(Category (I or II),Flag Name)=sort number
- +29 SET DGX=0
- +30 FOR
- SET DGX=$ORDER(@DGPFARR@(DGX))
- if 'DGX
- QUIT
- Begin DoDot:1
- +31 SET DGCAT=$SELECT($PIECE(@DGPFARR@(DGX,"FLAG"),U)[26.11:2,1:1)
- +32 SET DGINDX(DGCAT,$PIECE(@DGPFARR@(DGX,"FLAG"),U,2))=DGX
- End DoDot:1
- +33 ;
- +34 ;build sorted data array -
- +35 SET (DGCAT,DGX)=0
- +36 FOR
- SET DGCAT=$ORDER(DGINDX(DGCAT))
- if 'DGCAT
- QUIT
- Begin DoDot:1
- +37 SET DGNAME=""
- +38 FOR
- SET DGNAME=$ORDER(DGINDX(DGCAT,DGNAME))
- if DGNAME=""
- QUIT
- Begin DoDot:2
- +39 SET DGX=DGX+1
- +40 MERGE @DGSORT@(DGX)=@DGPFARR@(DGINDX(DGCAT,DGNAME))
- End DoDot:2
- End DoDot:1
- +41 ;
- +42 ;remove input array and replace with sorted array, kill sort array
- +43 KILL @DGPFARR
- +44 MERGE @DGPFARR=@DGSORT
- +45 KILL @DGSORT
- +46 ;
- +47 QUIT 1
- +48 ;
- ACTDT ; update PRF Software Activation Date field in (#26.18)
- +1 ; This utility should only be run at the Alpha and Beta test sites
- +2 ; of the Patient Record Flags Project, Patch DG*5.3*425.
- +3 ; If necessary, this entry point will change the date that the
- +4 ; Patient Record Flags (PRF) System became active.
- +5 ; The (#1) PRF SOFTWARE ACTIVATION DATE field of the (#26.18) PRF
- +6 ; PARAMETERS file, will be changed to: SEP 25, 2003
- +7 ;
- +8 ; Input: none
- +9 ;
- +10 ; Output: User message on successful or failure of file update
- +11 ;
- +12 ; Nationally Released Software Activation Date value
- NEW DGACTDT
- +13 ; IEN - internal entry # OF (#26.18) FILE
- NEW DGIENS
- +14 ; PRF Software Activation Date field #
- NEW DGFLD
- +15 ; FDA data array for filer
- NEW DGFDA
- +16 ; error message array returned from filer
- NEW DGERR
- +17 ; error message for display
- NEW DGERRMSG
- +18 ; current internal/external values of field
- NEW DGPARM
- +19 ;
- +20 SET DGACTDT="SEP 25, 2003"
- +21 SET DGIENS="1,"
- +22 SET DGFLD=1
- +23 ;
- +24 ; display user message
- +25 WRITE !!,"Updating the PRF SOFTWARE ACTIVATION DATE (#1) field in the PRF PARAMETERS FILE (#26.18) to the value of SEP 25, 2003..."
- +26 ;
- +27 ; checks for necessary programmer variables
- +28 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
- Begin DoDot:1
- +29 SET DGERRMSG="Your programming variables are not set up properly."
- End DoDot:1
- +30 ;
- +31 ; check if activation is not less than the current date
- +32 IF '$DATA(DGERRMSG)
- IF DT<3030925
- Begin DoDot:1
- +33 SET DGERRMSG="This file/field update can't be run before the date of SEP 25, 2003 is reached."
- End DoDot:1
- +34 ;
- +35 ; get current activation date from PRF PARAMETERS (#26.18) file
- +36 IF '$DATA(DGERRMSG)
- Begin DoDot:1
- +37 DO GETS^DIQ(26.18,"1,",1,"IE","DGPARM","DGERR")
- +38 ;
- +39 ; check for errors and inform the user
- +40 IF $DATA(DGERR)
- Begin DoDot:2
- +41 SET DGERRMSG=$GET(DGERR("DIERR",1,"TEXT",1))
- End DoDot:2
- QUIT
- +42 ;
- +43 ; check to make sure field is not set already
- +44 IF $GET(DGPARM(26.18,"1,",1,"I"))=3030925
- Begin DoDot:2
- +45 SET DGERRMSG="The date value is already set to SEP 25, 2003."
- End DoDot:2
- End DoDot:1
- +46 ;
- +47 ; now start the (#26.18) filing process
- +48 IF '$DATA(DGERRMSG)
- Begin DoDot:1
- +49 ;
- +50 ; DELETE activation date before filing since field is uneditable
- +51 SET DGFDA(26.18,DGIENS,1)="@"
- +52 DO FILE^DIE("","DGFDA","DGERR")
- +53 ;
- +54 ; check for errors and inform the user
- +55 IF $DATA(DGERR)
- Begin DoDot:2
- +56 SET DGERRMSG=$GET(DGERR("DIERR",1,"TEXT",1))
- End DoDot:2
- QUIT
- +57 ;
- +58 ; setup and file the new activation date value (external)
- +59 SET DGFDA(26.18,DGIENS,1)=DGACTDT
- +60 DO FILE^DIE("SE","DGFDA","DGERR")
- +61 ;
- +62 ; check for success or errors and inform the user of update status
- +63 IF $DATA(DGERR)
- Begin DoDot:2
- +64 SET DGERRMSG=$GET(DGERR("DIERR",1,"TEXT",1))
- End DoDot:2
- QUIT
- End DoDot:1
- +65 ;
- +66 ; display successful/failure file update - updated field and value
- +67 WRITE !!,$CHAR(7)
- +68 IF $DATA(DGERRMSG)
- Begin DoDot:1
- +69 WRITE "Field could not be updated...",DGERRMSG
- End DoDot:1
- +70 IF '$TEST
- Begin DoDot:1
- +71 WRITE "Field was successfully changed from ",$GET(DGPARM(26.18,"1,",1,"E"))," to ",$GET(DGFDA(26.18,DGIENS,DGFLD)),"."
- End DoDot:1
- +72 ;
- +73 QUIT
- +74 ;
- +75 ;
- BLDTFL(DGDFN,DGTFL) ;build array of Treating Facilities
- +1 ; This function builds an array of INSTITUTION (#4) file pointers
- +2 ; that are non-local medical treating facilities for a given patient.
- +3 ;
- +4 ; Input:
- +5 ; DGDFN - pointer to patient in PATIENT (#2) file
- +6 ;
- +7 ; Output:
- +8 ; Function value - 1 on results returned; 0 on failure
- +9 ; DGTFL - array of treating facility INSTITUTION (#4) file pointerS
- +10 ; Format: DGTFL(pointer)=date last treated
- +11 NEW DGSTAT,DGSTATI,DGKEY,DGOUT,DGI,DGSTI,DGIEN,DGDLT
- +12 SET DGSTAT=$PIECE($$SITE^VASITE,U,3)
- +13 SET DGSTATI=$PIECE($$SITE^VASITE,U)
- +14 SET DGKEY=DGDFN_U_"PI"_U_"USVHA"_U_DGSTAT
- +15 DO TFL^VAFCTFU2(.DGOUT,DGKEY)
- +16 SET DGI=""
- FOR
- SET DGI=$ORDER(DGOUT(DGI))
- if DGI=""
- QUIT
- Begin DoDot:1
- +17 IF $PIECE(DGOUT(DGI),U,2)="PI"
- IF $PIECE(DGOUT(DGI),U,3)="USVHA"
- Begin DoDot:2
- +18 IF $PIECE(DGOUT(DGI),U,4)="200CRNR"
- Begin DoDot:3
- +19 SET DGSTI=$$IEN^XUAF4($PIECE(DGOUT(DGI),U,4))
- +20 SET DGIEN=$ORDER(^DGCN(391.91,"AINST",DGSTI,DGDFN,""))
- +21 if DGIEN=""
- QUIT
- +22 SET DGDLT=+$PIECE($GET(^DGCN(391.91,DGIEN,0)),U,3)
- +23 SET DGTFL(DGSTI)=DGDLT
- +24 QUIT
- End DoDot:3
- +25 SET DGSTI=$$IEN^XUAF4($PIECE(DGOUT(DGI),U,4))
- +26 ;Q:DGSTI=""
- +27 if $$GET1^DIQ(4,DGSTI_",",13)="OTHER"!(+$$STA^XUAF4(DGSTI)=200)!(DGSTI=DGSTATI)
- QUIT
- +28 SET DGIEN=$ORDER(^DGCN(391.91,"AINST",DGSTI,DGDFN,""))
- +29 if DGIEN=""
- QUIT
- +30 SET DGDLT=+$PIECE($GET(^DGCN(391.91,DGIEN,0)),U,3)
- +31 ;DG*5.3*1054 only setting entries that are VistAs and PI/USHVA records
- SET DGTFL(DGSTI)=DGDLT
- +32 ; S:DGSTI'=DGSTATI DGTFL(DGSTI)=DGDLT
- End DoDot:2
- End DoDot:1
- +33 QUIT $SELECT(+$ORDER(DGTFL(0)):1,1:0)
- +34 ;
- +35 ;This subroutine converts the treating facility list returned by $$BLDTFL to
- +36 ;the format expected by XMIT^DGPFHLU6.
- +37 ;
- +38 ;Input:
- +39 ; DGDFN - pointer to the patient in the PATIENT (#2) file
- +40 ;Output:
- +41 ; DGTFL - array in the format DGTFL(#)=station number (not pointer)
- BLDTFL2(DGDFN,DGTFL) ;
- +1 NEW DGI,DGJ,DGTMP,DGRET
- +2 SET DGRET=$$BLDTFL(DGDFN,.DGTMP)
- +3 SET DGJ=0
- +4 SET DGI=""
- FOR
- SET DGI=$ORDER(DGTMP(DGI))
- if DGI=""
- QUIT
- Begin DoDot:1
- +5 SET DGJ=DGJ+1
- +6 SET DGTFL(DGJ)=$$STA^XUAF4(DGI)
- End DoDot:1
- +7 QUIT