DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 12/17/03 2:56pm
;;5.3;Registration;**425,554,650,1007,1015**;Aug 13, 1993;Build 21
;
; 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
. ;
. ;IHS/OIT/LJF 12/22/2006 PATCH 1007 set SSN to chart # with dashes
. S DGPAT("SSN")=$$HRCND^BDGF2($$HRCN^BDGF2(DGDFN,+$G(DUZ(2))))
. ;
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 DGLOC ;pointer to local facility in INSTITUTION (#4) file
N DGDLT ;date last treated
N DGFAC ;TFL API results array
N DGI ;generic counter
N DGINST ;pointer to INSTITUTION (#4) file
;
Q:$G(DGDFN)'>0 0 ;validate input parameter
;
D TFL^VAFCTFU1(.DGFAC,DGDFN)
S DGLOC=$P($$SITE^VASITE(),U)
S DGI=0
F S DGI=$O(DGFAC(DGI)) Q:'DGI D
. S DGINST=$$IEN^XUAF4($P(DGFAC(DGI),U))
. Q:DGINST'>0
. Q:DGINST=DGLOC ;filter local facility
. Q:'$$TF^XUAF4(DGINST) ;facility must be active treating facility
. S DGDLT=+$P(DGFAC(DGI),U,3)
. S DGTFL(DGINST)=DGDLT
;
Q $S(+$O(DGTFL(0)):1,1:0)
DGPFUT2 ;ALB/KCL - PRF UTILITIES CONTINUED ; 12/17/03 2:56pm
+1 ;;5.3;Registration;**425,554,650,1007,1015**;Aug 13, 1993;Build 21
+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
+37 ;
+38 ;IHS/OIT/LJF 12/22/2006 PATCH 1007 set SSN to chart # with dashes
+39 SET DGPAT("SSN")=$$HRCND^BDGF2($$HRCN^BDGF2(DGDFN,+$GET(DUZ(2))))
+40 ;
End DoDot:1
+41 QUIT RESULT
+42 ;
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 ;
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 ;
+12 ;pointer to local facility in INSTITUTION (#4) file
NEW DGLOC
+13 ;date last treated
NEW DGDLT
+14 ;TFL API results array
NEW DGFAC
+15 ;generic counter
NEW DGI
+16 ;pointer to INSTITUTION (#4) file
NEW DGINST
+17 ;
+18 ;validate input parameter
IF $GET(DGDFN)'>0
QUIT 0
+19 ;
+20 DO TFL^VAFCTFU1(.DGFAC,DGDFN)
+21 SET DGLOC=$PIECE($$SITE^VASITE(),U)
+22 SET DGI=0
+23 FOR
SET DGI=$ORDER(DGFAC(DGI))
IF 'DGI
QUIT
Begin DoDot:1
+24 SET DGINST=$$IEN^XUAF4($PIECE(DGFAC(DGI),U))
+25 IF DGINST'>0
QUIT
+26 ;filter local facility
IF DGINST=DGLOC
QUIT
+27 ;facility must be active treating facility
IF '$$TF^XUAF4(DGINST)
QUIT
+28 SET DGDLT=+$PIECE(DGFAC(DGI),U,3)
+29 SET DGTFL(DGINST)=DGDLT
End DoDot:1
+30 ;
+31 QUIT $SELECT(+$ORDER(DGTFL(0)):1,1:0)
