DGPFAA ;ALB/RPM,ASMR/JD - PRF ASSIGNMENT API'S ; 11/16/16 6:47pm
;;5.3;Registration;**425,921,951,1005**;Aug 13, 1993;Build 57
; Last edited: SHRPE/SGM - Sep 26, 2018 17:06
;
; DE2813 - JD - 10/28/15
;Done for eHMP project: DG*5.3*921
;Add logic to trigger an unsolicited update when a patient flag is updated.
;New code: Tag UU and any reference to that tag thereof.
; SHRPE/sgm - Jan 22, 2018
;Done for SHRPE project: DG*5.3*951
; GETASGN is called via ICR. So new input parameter introduced that
; is not part of the ICR for returning DBRS data.
;
; ICR# TYPE DESCRIPTION
;----- ---- ----------------------------------
; 872 CSub Global read of B index on file 101
; 2056 Sup GETS^DIQ
; 2053 Sup ^DIE: FILE, UPDATE
;10101 Sup EN1^XQOR
;
Q ;no direct entry
;
GETALL(DGDFN,DGIENS,DGSTAT,DGCAT) ;retrieve list of assignment IENs
;This function returns an array of patient record flag assignment IENs
;for a given patient. The returned IEN array may optionally be
;filtered by Active or Inactive status and by flag category.
;
; Input:
; DGDFN - (required) Pointer to patient in PATIENT (#2) file
; DGIENS - (required) Result array passed by reference
; DGSTAT - (optional) Status filter (0:Inactive,1:Active,"":Both).
; Defaults to Both.
; DGCAT - (optional) Category filter
; (1:Category I,2:Category II,"":Both). Defaults to Both.
;
; Output:
; Function Value - Count of returned IENs
; DGIENS - Output array subscripted by the assignment IENs
;
N DGCNT ;number of returned values
N DGIEN ;single IEN
N DGCKS ;check status flag (1:check, 0:ignore)
N DGFLAG ;pointer to #26.11 or #26.15
;
S DGCNT=0
I $G(DGDFN)>0,$D(^DGPF(26.13,"B",DGDFN)) D
. S DGFLAG=""
. S DGCKS=0
. S DGSTAT=$G(DGSTAT)
. I DGSTAT=0!(DGSTAT=1) S DGCKS=1
. S DGCAT=+$G(DGCAT)
. S DGCAT=$S(DGCAT=1:"26.15",DGCAT=2:"26.11",1:0)
. F S DGFLAG=$O(^DGPF(26.13,"C",DGDFN,DGFLAG)) Q:(DGFLAG="") D
. . I DGCAT,DGFLAG'[DGCAT Q
. . S DGIEN=$O(^DGPF(26.13,"C",DGDFN,DGFLAG,0))
. . I DGCKS,'$D(^DGPF(26.13,"D",DGDFN,DGSTAT,DGIEN)) Q
. . S DGCNT=DGCNT+1
. . S DGIENS(DGIEN)=""
Q DGCNT
;
GETASGN(DGPFIEN,DGPFA,DGDBRS) ;retrieve a single assignment record
;This function returns a single patient record flag assignment in an
;array format.
;
; Input:
; DGPFIEN - (required) Pointer to patient record flag assignment in
; PRF ASSIGNMENT (#26.13) file
; DGPFA - (required) Result array passed by reference
; DGDBRS - (optional) 1:return DBRS info in DGPFA() ; dg*951
;
; Output:
; Function Value - Returns 1 on success, 0 on failure
; DGPFA - Output array containing assignment record field
; values.
; Subscript Field# Data
; -------------- ------- ---------------------
; "DFN" .01 internal^external
; "FLAG" .02 internal^external
; "STATUS" .03 internal^external
; "OWNER" .04 internal^external
; "ORIGSITE" .05 internal^external
; "REVIEWDT" .06 internal^external
; "NARR",line#,0 1 character string
; If input DGDBRS>0 then
; "DBRS#",line# 2;.01 internal^external
; "DBRS OTHER",line# 2;.02 internal^external
; "DBRS DATE",line# 2;.03 internal^external
; "DBRS SITE",line# 2;.04 internal^external
;
N DGRSLT
;
S DGRSLT=0
I $G(DGPFIEN)>0,$D(^DGPF(26.13,DGPFIEN)) D
. N DGIENS ;IEN string for DIQ
. N DGFLDS ;results array for DIQ
. N DGERR ;error array for DIQ
. N ARR,DF,DIERR
. S DGIENS=DGPFIEN_","
. S DF="*" I +$G(DGDBRS) S DF="**" ; dg*5.3*951
. D GETS^DIQ(26.13,DGIENS,DF,"IEZ","DGFLDS","DGERR")
. Q:$D(DGERR)
. M ARR=DGFLDS(26.13,DGIENS)
. S DGRSLT=1
. S DGPFA("DFN")=$G(ARR(.01,"I"))_U_$G(ARR(.01,"E"))
. S DGPFA("FLAG")=$G(ARR(.02,"I"))_U_$G(ARR(.02,"E"))
. S DGPFA("STATUS")=$G(ARR(.03,"I"))_U_$G(ARR(.03,"E"))
. S DGPFA("OWNER")=$G(ARR(.04,"I"))_U_$G(ARR(.04,"E"))
. S DGPFA("ORIGSITE")=$G(ARR(.05,"I"))_U_$G(ARR(.05,"E"))
. S DGPFA("REVIEWDT")=$G(ARR(.06,"I"))_U_$G(ARR(.06,"E"))
. ;build assignment narrative word processing array
. M DGPFA("NARR")=ARR(1)
. K DGPFA("NARR","E"),DGPFA("NARR","I")
. I $D(DGFLDS(26.131)) D DBRS ; DG*5.3*951
. Q
Q DGRSLT
;
FNDASGN(DGPFDFN,DGPFFLG) ;Find Assignment
; This function finds a patient record flag assignment record.
;
; Input:
; DGDFN - Pointer to patient in the PATIENT (#2) file
; DGFLAG - Pointer to flag in either the PRF LOCAL FLAG (#26.11)
; file or the PRF NATIONAL FLAG (#26.15) file
;
; Output:
; Function Value - Returns IEN of existing record on success, 0 on
; failure
;
N DGIEN
;
I $G(DGPFDFN)>0,($G(DGPFFLG)>0) D
. S DGIEN=$O(^DGPF(26.13,"C",DGPFDFN,DGPFFLG,0))
Q $S($G(DGIEN)>0:DGIEN,1:0)
;
STOASGN(DGPFA,DGPFERR,DGPFUV) ;
;Store a single PRF ASSIGNMENT (#26.13) file record
;
; Input:
; DGPFA - (required) array of values to be filed (see GETASGN tag
; above for valid array structure)
; DGPFA() contains 2 "^"-pieces when called from AF/EF
; 1 "^"-piece when called from HL
; DGPFA("ACTION")=DGPFAH("ACTION") added by EF action and HL
; DGPFA("ACTION") = internal [ACTION; 26.14,.03]
; DGPFERR - (optional) passed by reference to contain error messages
; DGPFUV - (optional) see STOALL
; required to file DBRS data
;
; Output:
; Function Value - Returns IEN of record on success, 0 on failure
; DGPFERR - Undefined on success, error message on failure
;
N I,X,DGFLD,DGIEN,DGPFERR,DGSUB
S DGPFUV=$$UV
S X="ACTION^DFN^FLAG^ORIGSITE^OWNER^STATUS"
F I=1:1:$L(X,U) S DGSUB=$P(X,U,I),DGFLD(DGSUB)=$P($G(DGPFA(DGSUB)),U)
;
;only build DGFLD("REVIEWDT") if "REVIEWDT" is passed
I $D(DGPFA("REVIEWDT"))=1 S DGFLD("REVIEWDT")=$P(DGPFA("REVIEWDT"),U,1)
;
I $D(DGPFA("NARR")) M DGFLD("NARR")=DGPFA("NARR")
;
;REFRESH option may reset STATUS value - DG*5.3*951
S X=DGFLD("ACTION") I (X=7)!(X=8) S DGFLD("STATUS")=X-7
;
I $$VALID^DGPFUT("DGPFAA1",26.13,.DGFLD,.DGPFERR) D
. N X,DGDBRSE,DGCUR,DGFDA,DGFDAIEN,DGIENS,UPD
. S DGIEN=$$FNDASGN^DGPFAA(DGFLD("DFN"),DGFLD("FLAG"))
. I DGIEN S X=$$GETASGN(DGIEN,.DGCUR,1)
. I DGIEN S DGIENS=DGIEN_","
. E S DGIENS="+1,"
. S DGFDA(26.13,DGIENS,.01)=DGFLD("DFN")
. S DGFDA(26.13,DGIENS,.02)=DGFLD("FLAG")
. S DGFDA(26.13,DGIENS,.03)=DGFLD("STATUS")
. S DGFDA(26.13,DGIENS,.04)=DGFLD("OWNER")
. S DGFDA(26.13,DGIENS,.05)=DGFLD("ORIGSITE")
. ;
. ;only touch REVIEW DATE (#.06) field if "REVIEWDT" is passed
. ;if called from REFRESH option re-evaluate - DG*5.3*951
. S X=DGFLD("ACTION") I (X=7)!(X=8) D
. . I '$$ISDIV^DGPFUT(DGFLD("OWNER")) S DGFLD("REVIEWDT")="" Q
. . I 'DGFLD("STATUS") S DGFLD("REVIEWDT")="" Q
. . I +$G(DGCUR("REVIEWDT")) Q
. . ;calculate the default review date
. . S DGFLD("REVIEWDT")=$$GETRDT^DGPFAA3(DGFLD("FLAG"),$$NOW^XLFDT)
. . Q
. I $D(DGFLD("REVIEWDT")) S DGFDA(26.13,DGIENS,.06)=DGFLD("REVIEWDT")
. ;
. I $D(DGFLD("NARR")) S DGFDA(26.13,DGIENS,1)=$NA(DGFLD("NARR"))
. ;
. ;add in DBRS# data into .DGFDA ; dg*5.3*951
. ; if all existing DBRS data was deleted, $D(DGPFA("DBRS#"))=0
. ; DGPFA("ACTION")=History action code (may not be present)
. ;
. I DGPFUV'=-1,$L($T(AASGN^DGPFUT6)),+$$FLAG(DGFLD("FLAG")) D
. . N ACT S ACT=+DGFLD("ACTION")
. . I ACT=3 S DGPFUV=""
. . I ACT=5 S DGPFUV="d"
. . I ACT=7 S DGPFUV="D"
. . D AASGN^DGPFUT6(DGIENS,.DGPFA,.DGFDA,DGPFUV,.DGPFERR)
. . Q
. Q:$D(DGPFERR)
. ;
. ;determine if update or file should be called
. S UPD=(DGIENS["+") I 'UPD D
. . N I,J
. . S I=0 F J=0:0 S I=$O(DGFDA(26.131,I)) Q:I="" I I["+" S UPD=1 Q
. . Q
. ;
. ; variable needed for ^DD(26.131,.01,"DEL")
. I $G(DGPFA("ACTION"))=5 S DGDBRSE=1
. I 'UPD D
. . N DGERR,DIERR
. . D FILE^DIE("","DGFDA","DGERR")
. . I $D(DGERR) S DGIEN=0
. . ;DG*5.3*921 - Trigger an unsolicited update if a patient flag is updated
. . ;I '$D(DGERR) D UU(.DGPFA)
. . Q
. E D
. . N DGERR,DIERR
. . D UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR")
. . I $D(DGERR),DGIENS'="+1," S DGIEN=0
. . I '$D(DGERR),DGIENS="+1," S DGIEN=$G(DGFDAIEN(1))
. . Q
. Q
Q $S($G(DGIEN)>0:DGIEN,1:0)
;
STOALL(DGPFA,DGPFAH,DGPFERR,DGPFUV) ;
;Store both the assignment and history record
;This function acts as a wrapper around the $$STOASGN and $$STOHIST
;filer calls.
;
; INPUT PARAMETERS:
; DGPFA - (required) array of assignment values to be filed (see
; $$GETASGN^DGPFAA for valid array structure)
; DGPFAH - (required) array of assignment history values to be filed
; (see $$STOHIST^DGPFAAH for valid array structure)
; DGPFERR - (optional) passed by reference to contain error messages
; DGPFUV - (optional) generic flag, single character, intent allow
; calls to STOALL to flag special handling cases
; D: STOASGN - first, mark all existing DBRS records for
; delete in FDA(). DGPFUT62 processing continues
; d: STOASGN - first, mark all existing DBRS records for
; delete in FDA(). DGPFUT62 processing stops and exits
; -1: DGPFUV was not passed in
; [difference between null and '$D(DGPFUV)]
;
; Output:
; Function Value - Returns circumflex("^") delimited results of
; $$STOASGN^DGPFAA and $$STOHIST^DGPFAAH calls
; DGPFERR - Undefined on success, error message on failure
;
N DGOIEN ;existing assignment file IEN used for "roll-back"
N DGPFOA ;existing assignment data array used for "roll-back"
N DGAIEN ;assignment file IEN
N DGAHIEN ;assignment history file IEN
N DGDFN ;"DFN" value
N DGFLG ;"FLAG" value
;
S (DGAIEN,DGAHIEN)=0
S DGDFN=$P($G(DGPFA("DFN")),U,1)
S DGFLG=$P($G(DGPFA("FLAG")),U,1)
S DGPFUV=$$UV
S DGOIEN=$$FNDASGN^DGPFAA(DGDFN,DGFLG)
D ;drops out of block if can't rollback or assignment filer fails
. I DGOIEN,'$$GETASGN^DGPFAA(DGOIEN,.DGPFOA,1) Q ;can't rollback, so quit
. ;
. ;store the assignment
. I '$D(DGPFA("ACTION")) S DGPFA("ACTION")=+$G(DGPFAH("ACTION"))
. S DGAIEN=$$STOASGN^DGPFAA(.DGPFA,.DGPFERR,DGPFUV)
. I $D(DGPFERR) S DGAIEN=0
. Q:'DGAIEN ;assignment filer failed, so quit
. ;
. ;store the assignment history
. S DGPFAH("ASSIGN")=DGAIEN
. S DGAHIEN=$$STOHIST^DGPFAAH(.DGPFAH,.DGPFERR)
. I $D(DGPFERR) S DGAHIEN=0
. I DGAHIEN=0 D ;history filer failed, so rollback the assignment
. . I 'DGOIEN,'$D(DGPFOA) S DGPFOA("DFN")="@"
. . I $$ROLLBACK^DGPFAA2(DGAIEN,.DGPFOA) S DGAIEN=0
. . Q
. ;
. ;post protocol event
. I DGAIEN D UU(DGAIEN,.DGPFA)
. Q
Q $S(+$G(DGAHIEN)=0:0,1:DGAIEN_"^"_DGAHIEN)
;
UU(DGIEN,DGPRF) ;Fire off event protocol
; DGIEN - (required) Pointer to patient record flag assignment in
; PRF ASSIGNMENT (#26.13) file
; DGPRF - (required) array of assignment values to be filed (see
; $$GETASGN for array structure)
N DGDFN,X
S DGDFN=+$G(DGPRF("DFN"))
S X=+$O(^ORD(101,"B","DGPF PRF EVENT",0))_";ORD(101,"
D:X EN^XQOR
Q
;
DBRS ; DG*5.3*951
; add DBRS data to DGPFA()
N I,X,Y,IENS
S (I,IENS)=0
F S IENS=$O(DGFLDS(26.131,IENS)) Q:IENS="" D
. N ARR M ARR=DGFLDS(26.131,IENS)
. S I=I+1
. S X=ARR(.01,"I") S DGPFA("DBRS#",I)=X_U_X
. S (X,Y)=ARR(.02,"I") S:Y="" Y="<no value>"
. S DGPFA("DBRS OTHER",I)=X_U_Y
. S DGPFA("DBRS DATE",I)=ARR(.03,"I")_U_ARR(.03,"E")
. S DGPFA("DBRS SITE",I)=ARR(.04,"I")_U_ARR(.04,"E")
. Q
Q
;
FLAG(VARPTR) ;
; Verify that variable flag pointer is BEHAVIORAL, Category I
; DGPFIN - required - variable pointer to 26.11 / 26.15
Q $$FLAG^DGPFUT6(VARPTR,"BEHAVIORAL","I")
;
UV() ; return edited value for DGPFUV
; if '$D(DGPFUV) then set DGPFUV=-1
; also called from ^DGPFUT62
N Y,RET
S RET=-1
I '$D(DGPFUV) S DGPFUV=-1 ;DG*991
S Y=DGPFUV I $D(DGPFUV)#2 D
. I $L(Y)<2 S RET=$S("dD"[Y:Y,1:"") Q
. I Y["d" S RET="d" Q
. I (Y["AD")!(Y["DA") S RET="D" Q
. S RET=$S(Y["D":"D",1:"")
. Q
Q RET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFAA 12675 printed Apr 09, 2024@21:41:30 Page 2
DGPFAA ;ALB/RPM,ASMR/JD - PRF ASSIGNMENT API'S ; 11/16/16 6:47pm
+1 ;;5.3;Registration;**425,921,951,1005**;Aug 13, 1993;Build 57
+2 ; Last edited: SHRPE/SGM - Sep 26, 2018 17:06
+3 ;
+4 ; DE2813 - JD - 10/28/15
+5 ;Done for eHMP project: DG*5.3*921
+6 ;Add logic to trigger an unsolicited update when a patient flag is updated.
+7 ;New code: Tag UU and any reference to that tag thereof.
+8 ; SHRPE/sgm - Jan 22, 2018
+9 ;Done for SHRPE project: DG*5.3*951
+10 ; GETASGN is called via ICR. So new input parameter introduced that
+11 ; is not part of the ICR for returning DBRS data.
+12 ;
+13 ; ICR# TYPE DESCRIPTION
+14 ;----- ---- ----------------------------------
+15 ; 872 CSub Global read of B index on file 101
+16 ; 2056 Sup GETS^DIQ
+17 ; 2053 Sup ^DIE: FILE, UPDATE
+18 ;10101 Sup EN1^XQOR
+19 ;
+20 ;no direct entry
QUIT
+21 ;
GETALL(DGDFN,DGIENS,DGSTAT,DGCAT) ;retrieve list of assignment IENs
+1 ;This function returns an array of patient record flag assignment IENs
+2 ;for a given patient. The returned IEN array may optionally be
+3 ;filtered by Active or Inactive status and by flag category.
+4 ;
+5 ; Input:
+6 ; DGDFN - (required) Pointer to patient in PATIENT (#2) file
+7 ; DGIENS - (required) Result array passed by reference
+8 ; DGSTAT - (optional) Status filter (0:Inactive,1:Active,"":Both).
+9 ; Defaults to Both.
+10 ; DGCAT - (optional) Category filter
+11 ; (1:Category I,2:Category II,"":Both). Defaults to Both.
+12 ;
+13 ; Output:
+14 ; Function Value - Count of returned IENs
+15 ; DGIENS - Output array subscripted by the assignment IENs
+16 ;
+17 ;number of returned values
NEW DGCNT
+18 ;single IEN
NEW DGIEN
+19 ;check status flag (1:check, 0:ignore)
NEW DGCKS
+20 ;pointer to #26.11 or #26.15
NEW DGFLAG
+21 ;
+22 SET DGCNT=0
+23 IF $GET(DGDFN)>0
IF $DATA(^DGPF(26.13,"B",DGDFN))
Begin DoDot:1
+24 SET DGFLAG=""
+25 SET DGCKS=0
+26 SET DGSTAT=$GET(DGSTAT)
+27 IF DGSTAT=0!(DGSTAT=1)
SET DGCKS=1
+28 SET DGCAT=+$GET(DGCAT)
+29 SET DGCAT=$SELECT(DGCAT=1:"26.15",DGCAT=2:"26.11",1:0)
+30 FOR
SET DGFLAG=$ORDER(^DGPF(26.13,"C",DGDFN,DGFLAG))
if (DGFLAG="")
QUIT
Begin DoDot:2
+31 IF DGCAT
IF DGFLAG'[DGCAT
QUIT
+32 SET DGIEN=$ORDER(^DGPF(26.13,"C",DGDFN,DGFLAG,0))
+33 IF DGCKS
IF '$DATA(^DGPF(26.13,"D",DGDFN,DGSTAT,DGIEN))
QUIT
+34 SET DGCNT=DGCNT+1
+35 SET DGIENS(DGIEN)=""
End DoDot:2
End DoDot:1
+36 QUIT DGCNT
+37 ;
GETASGN(DGPFIEN,DGPFA,DGDBRS) ;retrieve a single assignment record
+1 ;This function returns a single patient record flag assignment in an
+2 ;array format.
+3 ;
+4 ; Input:
+5 ; DGPFIEN - (required) Pointer to patient record flag assignment in
+6 ; PRF ASSIGNMENT (#26.13) file
+7 ; DGPFA - (required) Result array passed by reference
+8 ; DGDBRS - (optional) 1:return DBRS info in DGPFA() ; dg*951
+9 ;
+10 ; Output:
+11 ; Function Value - Returns 1 on success, 0 on failure
+12 ; DGPFA - Output array containing assignment record field
+13 ; values.
+14 ; Subscript Field# Data
+15 ; -------------- ------- ---------------------
+16 ; "DFN" .01 internal^external
+17 ; "FLAG" .02 internal^external
+18 ; "STATUS" .03 internal^external
+19 ; "OWNER" .04 internal^external
+20 ; "ORIGSITE" .05 internal^external
+21 ; "REVIEWDT" .06 internal^external
+22 ; "NARR",line#,0 1 character string
+23 ; If input DGDBRS>0 then
+24 ; "DBRS#",line# 2;.01 internal^external
+25 ; "DBRS OTHER",line# 2;.02 internal^external
+26 ; "DBRS DATE",line# 2;.03 internal^external
+27 ; "DBRS SITE",line# 2;.04 internal^external
+28 ;
+29 NEW DGRSLT
+30 ;
+31 SET DGRSLT=0
+32 IF $GET(DGPFIEN)>0
IF $DATA(^DGPF(26.13,DGPFIEN))
Begin DoDot:1
+33 ;IEN string for DIQ
NEW DGIENS
+34 ;results array for DIQ
NEW DGFLDS
+35 ;error array for DIQ
NEW DGERR
+36 NEW ARR,DF,DIERR
+37 SET DGIENS=DGPFIEN_","
+38 ; dg*5.3*951
SET DF="*"
IF +$GET(DGDBRS)
SET DF="**"
+39 DO GETS^DIQ(26.13,DGIENS,DF,"IEZ","DGFLDS","DGERR")
+40 if $DATA(DGERR)
QUIT
+41 MERGE ARR=DGFLDS(26.13,DGIENS)
+42 SET DGRSLT=1
+43 SET DGPFA("DFN")=$GET(ARR(.01,"I"))_U_$GET(ARR(.01,"E"))
+44 SET DGPFA("FLAG")=$GET(ARR(.02,"I"))_U_$GET(ARR(.02,"E"))
+45 SET DGPFA("STATUS")=$GET(ARR(.03,"I"))_U_$GET(ARR(.03,"E"))
+46 SET DGPFA("OWNER")=$GET(ARR(.04,"I"))_U_$GET(ARR(.04,"E"))
+47 SET DGPFA("ORIGSITE")=$GET(ARR(.05,"I"))_U_$GET(ARR(.05,"E"))
+48 SET DGPFA("REVIEWDT")=$GET(ARR(.06,"I"))_U_$GET(ARR(.06,"E"))
+49 ;build assignment narrative word processing array
+50 MERGE DGPFA("NARR")=ARR(1)
+51 KILL DGPFA("NARR","E"),DGPFA("NARR","I")
+52 ; DG*5.3*951
IF $DATA(DGFLDS(26.131))
DO DBRS
+53 QUIT
End DoDot:1
+54 QUIT DGRSLT
+55 ;
FNDASGN(DGPFDFN,DGPFFLG) ;Find Assignment
+1 ; This function finds a patient record flag assignment record.
+2 ;
+3 ; Input:
+4 ; DGDFN - Pointer to patient in the PATIENT (#2) file
+5 ; DGFLAG - Pointer to flag in either the PRF LOCAL FLAG (#26.11)
+6 ; file or the PRF NATIONAL FLAG (#26.15) file
+7 ;
+8 ; Output:
+9 ; Function Value - Returns IEN of existing record on success, 0 on
+10 ; failure
+11 ;
+12 NEW DGIEN
+13 ;
+14 IF $GET(DGPFDFN)>0
IF ($GET(DGPFFLG)>0)
Begin DoDot:1
+15 SET DGIEN=$ORDER(^DGPF(26.13,"C",DGPFDFN,DGPFFLG,0))
End DoDot:1
+16 QUIT $SELECT($GET(DGIEN)>0:DGIEN,1:0)
+17 ;
STOASGN(DGPFA,DGPFERR,DGPFUV) ;
+1 ;Store a single PRF ASSIGNMENT (#26.13) file record
+2 ;
+3 ; Input:
+4 ; DGPFA - (required) array of values to be filed (see GETASGN tag
+5 ; above for valid array structure)
+6 ; DGPFA() contains 2 "^"-pieces when called from AF/EF
+7 ; 1 "^"-piece when called from HL
+8 ; DGPFA("ACTION")=DGPFAH("ACTION") added by EF action and HL
+9 ; DGPFA("ACTION") = internal [ACTION; 26.14,.03]
+10 ; DGPFERR - (optional) passed by reference to contain error messages
+11 ; DGPFUV - (optional) see STOALL
+12 ; required to file DBRS data
+13 ;
+14 ; Output:
+15 ; Function Value - Returns IEN of record on success, 0 on failure
+16 ; DGPFERR - Undefined on success, error message on failure
+17 ;
+18 NEW I,X,DGFLD,DGIEN,DGPFERR,DGSUB
+19 SET DGPFUV=$$UV
+20 SET X="ACTION^DFN^FLAG^ORIGSITE^OWNER^STATUS"
+21 FOR I=1:1:$LENGTH(X,U)
SET DGSUB=$PIECE(X,U,I)
SET DGFLD(DGSUB)=$PIECE($GET(DGPFA(DGSUB)),U)
+22 ;
+23 ;only build DGFLD("REVIEWDT") if "REVIEWDT" is passed
+24 IF $DATA(DGPFA("REVIEWDT"))=1
SET DGFLD("REVIEWDT")=$PIECE(DGPFA("REVIEWDT"),U,1)
+25 ;
+26 IF $DATA(DGPFA("NARR"))
MERGE DGFLD("NARR")=DGPFA("NARR")
+27 ;
+28 ;REFRESH option may reset STATUS value - DG*5.3*951
+29 SET X=DGFLD("ACTION")
IF (X=7)!(X=8)
SET DGFLD("STATUS")=X-7
+30 ;
+31 IF $$VALID^DGPFUT("DGPFAA1",26.13,.DGFLD,.DGPFERR)
Begin DoDot:1
+32 NEW X,DGDBRSE,DGCUR,DGFDA,DGFDAIEN,DGIENS,UPD
+33 SET DGIEN=$$FNDASGN^DGPFAA(DGFLD("DFN"),DGFLD("FLAG"))
+34 IF DGIEN
SET X=$$GETASGN(DGIEN,.DGCUR,1)
+35 IF DGIEN
SET DGIENS=DGIEN_","
+36 IF '$TEST
SET DGIENS="+1,"
+37 SET DGFDA(26.13,DGIENS,.01)=DGFLD("DFN")
+38 SET DGFDA(26.13,DGIENS,.02)=DGFLD("FLAG")
+39 SET DGFDA(26.13,DGIENS,.03)=DGFLD("STATUS")
+40 SET DGFDA(26.13,DGIENS,.04)=DGFLD("OWNER")
+41 SET DGFDA(26.13,DGIENS,.05)=DGFLD("ORIGSITE")
+42 ;
+43 ;only touch REVIEW DATE (#.06) field if "REVIEWDT" is passed
+44 ;if called from REFRESH option re-evaluate - DG*5.3*951
+45 SET X=DGFLD("ACTION")
IF (X=7)!(X=8)
Begin DoDot:2
+46 IF '$$ISDIV^DGPFUT(DGFLD("OWNER"))
SET DGFLD("REVIEWDT")=""
QUIT
+47 IF 'DGFLD("STATUS")
SET DGFLD("REVIEWDT")=""
QUIT
+48 IF +$GET(DGCUR("REVIEWDT"))
QUIT
+49 ;calculate the default review date
+50 SET DGFLD("REVIEWDT")=$$GETRDT^DGPFAA3(DGFLD("FLAG"),$$NOW^XLFDT)
+51 QUIT
End DoDot:2
+52 IF $DATA(DGFLD("REVIEWDT"))
SET DGFDA(26.13,DGIENS,.06)=DGFLD("REVIEWDT")
+53 ;
+54 IF $DATA(DGFLD("NARR"))
SET DGFDA(26.13,DGIENS,1)=$NAME(DGFLD("NARR"))
+55 ;
+56 ;add in DBRS# data into .DGFDA ; dg*5.3*951
+57 ; if all existing DBRS data was deleted, $D(DGPFA("DBRS#"))=0
+58 ; DGPFA("ACTION")=History action code (may not be present)
+59 ;
+60 IF DGPFUV'=-1
IF $LENGTH($TEXT(AASGN^DGPFUT6))
IF +$$FLAG(DGFLD("FLAG"))
Begin DoDot:2
+61 NEW ACT
SET ACT=+DGFLD("ACTION")
+62 IF ACT=3
SET DGPFUV=""
+63 IF ACT=5
SET DGPFUV="d"
+64 IF ACT=7
SET DGPFUV="D"
+65 DO AASGN^DGPFUT6(DGIENS,.DGPFA,.DGFDA,DGPFUV,.DGPFERR)
+66 QUIT
End DoDot:2
+67 if $DATA(DGPFERR)
QUIT
+68 ;
+69 ;determine if update or file should be called
+70 SET UPD=(DGIENS["+")
IF 'UPD
Begin DoDot:2
+71 NEW I,J
+72 SET I=0
FOR J=0:0
SET I=$ORDER(DGFDA(26.131,I))
if I=""
QUIT
IF I["+"
SET UPD=1
QUIT
+73 QUIT
End DoDot:2
+74 ;
+75 ; variable needed for ^DD(26.131,.01,"DEL")
+76 IF $GET(DGPFA("ACTION"))=5
SET DGDBRSE=1
+77 IF 'UPD
Begin DoDot:2
+78 NEW DGERR,DIERR
+79 DO FILE^DIE("","DGFDA","DGERR")
+80 IF $DATA(DGERR)
SET DGIEN=0
+81 ;DG*5.3*921 - Trigger an unsolicited update if a patient flag is updated
+82 ;I '$D(DGERR) D UU(.DGPFA)
+83 QUIT
End DoDot:2
+84 IF '$TEST
Begin DoDot:2
+85 NEW DGERR,DIERR
+86 DO UPDATE^DIE("","DGFDA","DGFDAIEN","DGERR")
+87 IF $DATA(DGERR)
IF DGIENS'="+1,"
SET DGIEN=0
+88 IF '$DATA(DGERR)
IF DGIENS="+1,"
SET DGIEN=$GET(DGFDAIEN(1))
+89 QUIT
End DoDot:2
+90 QUIT
End DoDot:1
+91 QUIT $SELECT($GET(DGIEN)>0:DGIEN,1:0)
+92 ;
STOALL(DGPFA,DGPFAH,DGPFERR,DGPFUV) ;
+1 ;Store both the assignment and history record
+2 ;This function acts as a wrapper around the $$STOASGN and $$STOHIST
+3 ;filer calls.
+4 ;
+5 ; INPUT PARAMETERS:
+6 ; DGPFA - (required) array of assignment values to be filed (see
+7 ; $$GETASGN^DGPFAA for valid array structure)
+8 ; DGPFAH - (required) array of assignment history values to be filed
+9 ; (see $$STOHIST^DGPFAAH for valid array structure)
+10 ; DGPFERR - (optional) passed by reference to contain error messages
+11 ; DGPFUV - (optional) generic flag, single character, intent allow
+12 ; calls to STOALL to flag special handling cases
+13 ; D: STOASGN - first, mark all existing DBRS records for
+14 ; delete in FDA(). DGPFUT62 processing continues
+15 ; d: STOASGN - first, mark all existing DBRS records for
+16 ; delete in FDA(). DGPFUT62 processing stops and exits
+17 ; -1: DGPFUV was not passed in
+18 ; [difference between null and '$D(DGPFUV)]
+19 ;
+20 ; Output:
+21 ; Function Value - Returns circumflex("^") delimited results of
+22 ; $$STOASGN^DGPFAA and $$STOHIST^DGPFAAH calls
+23 ; DGPFERR - Undefined on success, error message on failure
+24 ;
+25 ;existing assignment file IEN used for "roll-back"
NEW DGOIEN
+26 ;existing assignment data array used for "roll-back"
NEW DGPFOA
+27 ;assignment file IEN
NEW DGAIEN
+28 ;assignment history file IEN
NEW DGAHIEN
+29 ;"DFN" value
NEW DGDFN
+30 ;"FLAG" value
NEW DGFLG
+31 ;
+32 SET (DGAIEN,DGAHIEN)=0
+33 SET DGDFN=$PIECE($GET(DGPFA("DFN")),U,1)
+34 SET DGFLG=$PIECE($GET(DGPFA("FLAG")),U,1)
+35 SET DGPFUV=$$UV
+36 SET DGOIEN=$$FNDASGN^DGPFAA(DGDFN,DGFLG)
+37 ;drops out of block if can't rollback or assignment filer fails
Begin DoDot:1
+38 ;can't rollback, so quit
IF DGOIEN
IF '$$GETASGN^DGPFAA(DGOIEN,.DGPFOA,1)
QUIT
+39 ;
+40 ;store the assignment
+41 IF '$DATA(DGPFA("ACTION"))
SET DGPFA("ACTION")=+$GET(DGPFAH("ACTION"))
+42 SET DGAIEN=$$STOASGN^DGPFAA(.DGPFA,.DGPFERR,DGPFUV)
+43 IF $DATA(DGPFERR)
SET DGAIEN=0
+44 ;assignment filer failed, so quit
if 'DGAIEN
QUIT
+45 ;
+46 ;store the assignment history
+47 SET DGPFAH("ASSIGN")=DGAIEN
+48 SET DGAHIEN=$$STOHIST^DGPFAAH(.DGPFAH,.DGPFERR)
+49 IF $DATA(DGPFERR)
SET DGAHIEN=0
+50 ;history filer failed, so rollback the assignment
IF DGAHIEN=0
Begin DoDot:2
+51 IF 'DGOIEN
IF '$DATA(DGPFOA)
SET DGPFOA("DFN")="@"
+52 IF $$ROLLBACK^DGPFAA2(DGAIEN,.DGPFOA)
SET DGAIEN=0
+53 QUIT
End DoDot:2
+54 ;
+55 ;post protocol event
+56 IF DGAIEN
DO UU(DGAIEN,.DGPFA)
+57 QUIT
End DoDot:1
+58 QUIT $SELECT(+$GET(DGAHIEN)=0:0,1:DGAIEN_"^"_DGAHIEN)
+59 ;
UU(DGIEN,DGPRF) ;Fire off event protocol
+1 ; DGIEN - (required) Pointer to patient record flag assignment in
+2 ; PRF ASSIGNMENT (#26.13) file
+3 ; DGPRF - (required) array of assignment values to be filed (see
+4 ; $$GETASGN for array structure)
+5 NEW DGDFN,X
+6 SET DGDFN=+$GET(DGPRF("DFN"))
+7 SET X=+$ORDER(^ORD(101,"B","DGPF PRF EVENT",0))_";ORD(101,"
+8 if X
DO EN^XQOR
+9 QUIT
+10 ;
DBRS ; DG*5.3*951
+1 ; add DBRS data to DGPFA()
+2 NEW I,X,Y,IENS
+3 SET (I,IENS)=0
+4 FOR
SET IENS=$ORDER(DGFLDS(26.131,IENS))
if IENS=""
QUIT
Begin DoDot:1
+5 NEW ARR
MERGE ARR=DGFLDS(26.131,IENS)
+6 SET I=I+1
+7 SET X=ARR(.01,"I")
SET DGPFA("DBRS#",I)=X_U_X
+8 SET (X,Y)=ARR(.02,"I")
if Y=""
SET Y="<no value>"
+9 SET DGPFA("DBRS OTHER",I)=X_U_Y
+10 SET DGPFA("DBRS DATE",I)=ARR(.03,"I")_U_ARR(.03,"E")
+11 SET DGPFA("DBRS SITE",I)=ARR(.04,"I")_U_ARR(.04,"E")
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
FLAG(VARPTR) ;
+1 ; Verify that variable flag pointer is BEHAVIORAL, Category I
+2 ; DGPFIN - required - variable pointer to 26.11 / 26.15
+3 QUIT $$FLAG^DGPFUT6(VARPTR,"BEHAVIORAL","I")
+4 ;
UV() ; return edited value for DGPFUV
+1 ; if '$D(DGPFUV) then set DGPFUV=-1
+2 ; also called from ^DGPFUT62
+3 NEW Y,RET
+4 SET RET=-1
+5 ;DG*991
IF '$DATA(DGPFUV)
SET DGPFUV=-1
+6 SET Y=DGPFUV
IF $DATA(DGPFUV)#2
Begin DoDot:1
+7 IF $LENGTH(Y)<2
SET RET=$SELECT("dD"[Y:Y,1:"")
QUIT
+8 IF Y["d"
SET RET="d"
QUIT
+9 IF (Y["AD")!(Y["DA")
SET RET="D"
QUIT
+10 SET RET=$SELECT(Y["D":"D",1:"")
+11 QUIT
End DoDot:1
+12 QUIT RET
