- 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 Jan 18, 2025@03:47:56 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