DGPFLMA3 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 6/2/05 3:24pm
;;5.3;Registration;**425,623,554,650,864,951,1106**;Aug 13, 1993;Build 1
; Last Edited: SHRPE/SGM - Sep 25, 2018 17:31
;NOTES:
; 1/23/2018 - with addition of DBRS, when to not complete action
; changes from previous version. One can edit DBRS#
; only with no other changes.
; ICR# TYPE DESCRIPTION
;----- ---- -------------------------------
; 2050 Sup ^DIALOG: BLD, MSG
; 2051 Sup UPDATE^DIE
; 2054 Sup $$OREF^DILF
; 2056 Sup $$GET1^DIQ
;10028 Sup EN^DIWE
;10060 Sup File 200 FM read of all fields
;10103 Sup ^XLFDT: $$FMTE, $$NOW
;10113 Sup ^DIK
;10116 Sup ^VALM1: FULL, PAUSE
;10119 Sup EN^VALM2
;
QUIT
;
EF ;Entry point for DGPF EDIT ASSIGNMENT action protocol.
;
; Input: None
;
; Output:
; VALMBCK - 'R' = refresh screen
;
;input vars for EN^DIWE call
N X,Y,DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK
N DGAROOT ;assignment narrative word processing root
N DGCROOT ;assignment history comment word processing root
N DGABORT ;abort flag for entering assignment narrative
N DGASK ;return value from $$ANSWER^DGPFUT call
N DGOK ;ok flag for entering assignment narrative
N DGCODE ;action code
N DGDFN ;pointer to patient in PATIENT (#2) file
N DGIEN ;assignment ien
N DGPFA ;assignment array
N DGPFAH ;assignment history array
N DGPFERR ;if error returned from STOALL api call
N DGQ ;quit var for narrative edit
N DGRDAT ;review date
N DGRESULT ;result of STOALL api call
N DGERR ;error if unable to edit assignment
N DGETEXT ;error text
N DGSUB ;for loop var
N SEL ;user selection (list item)
N VALMY ;output of EN^VALM2 call, array of user selected entries
;
;set screen to full scroll region
D FULL^VALM1
;
;quit if selected action is not appropriate
I '$D(@VALMAR@("IDX")) D Q
. I '$G(DGDFN) S DGETEXT(1)="Patient has not been selected."
. E S DGETEXT(1)="Patient has no record flag assignments."
. D BLD^DIALOG(261129,.DGETEXT,"","DGERR","F")
. D MSG^DIALOG("WE","","","","DGERR") W $C(7)
. D PAUSE^VALM1
. S VALMBCK="R"
;
;allow user to select a SINGLE flag assignment for editing
S (DGIEN,VALMBCK)=""
D EN^VALM2($G(XQORNOD(0)),"S")
;
;process user selection
S SEL=$O(VALMY(""))
I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D
. N X
. S DGIEN=$P($G(@VALMAR@("IDX",SEL,SEL)),U)
. S DGDFN=$P($G(@VALMAR@("IDX",SEL,SEL)),U,2)
. ;
. ;attempt to obtain lock on assignment record
. I '$$LOCK^DGPFAA3(DGIEN) D Q
. . W !!,"Record flag assignment currently in use, cannot be edited!"
. . D PAUSE^VALM1
. ;
. ;init word processing arrays
. S DGAROOT=$NA(^TMP($J,"DGPFNARR"))
. S DGCROOT=$NA(^TMP($J,"DGPFCMNT"))
. K @DGAROOT,@DGCROOT
. ;
. ;get assignment into DGPFA array
. I '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1) D Q
. . W !!,"Unable to retrieve the record flag assignment selected."
. . D PAUSE^VALM1
. ;
. ;urgent address as female flag can't be edited dg*5.3*864
. I $P(DGPFA("FLAG"),",",2)="^URGENT ADDRESS AS FEMALE" D Q
. . W !!
. . W !!,"The URGENT ADDRESS AS FEMALE Flag assignment cannot be edited."
. . W !!
. . D PAUSE^VALM1
. ;
. ;is assignment edit allowed?
. I '$$EDTOK^DGPFAA2(.DGPFA,DUZ(2),"DGERR") D Q
. . W !!,"Assignment can not be edited..."
. . D MSG^DIALOG("WE","","",5,"DGERR")
. . D PAUSE^VALM1
. ;
. ;-if assignment is active, set available action codes to Continue
. ; and Inactivate; else set code to Reactivate
. ;-if Local Flag or PRF Phase 2 active, add Entered in Error code
. ;-dg*951 - add DBRS edit option. This action is worded to allow
. ; for future fields to be added without having to add new
. ; actions. DBRS edit action only available on actions Continue
. ; and Reactivate
. I +DGPFA("STATUS")=1 D
. . S DGCODE="S^C:Continue Assignment;I:Inactivate Assignment"
. . I $$P2ON^DGPFPARM()!(DGPFA("FLAG")["26.11") S DGCODE=DGCODE_";E:Entered in Error"
. . I $P(DGPFA("FLAG"),U,2)="BEHAVIORAL" D ; dg*5.3*951
. . . S DGCODE=DGCODE_";X:DBRS/Other Field Edit Only"
. . . Q
. . Q
. E S DGCODE="S^R:Reactivate Assignment"
. ;
. ;prompt user for assignment action, quit if no action selected
. ;"ACTION" will have a value from 1-6 ; dg*951
. S X=$$ANSWER^DGPFUT("Select an assignment action","",DGCODE)
. Q:(X=-1)
. S X=$F("CIREX",X) Q:'X S DGPFAH("ACTION")=X
. ;
. ;if assignment action is 'Inactivate' or 'Entered in Error',
. ;set status to 'Inactive'. default='Active'
. ;if action is DBRS do not change current status; DG*5.3*951
. I DGPFAH("ACTION")'=6 D
. . S DGPFA("STATUS")=$S(DGPFAH("ACTION")=3:0,DGPFAH("ACTION")=5:0,1:1)
. . Q
. ;
. ; DBRS ; DG*5.3*951
. I $$BEH,'$$EIE I '$$DBRSEDIT^DGPFUT6 Q
. ;
. ;if action is not 'Inactivate', then prompt user to edit the narr
. S (DGABORT,DGOK,DGQ)=0
. I 36'[DGPFAH("ACTION") D
. . F D Q:(DGOK!DGABORT!DGQ)
. . . N I,DGTX
. . . ; if action code not 'Entered in Error', can't force edit
. . . I '$$EIE D Q:(DGQ!DGABORT)
. . . . S DGASK=$$ANSWER^DGPFUT("Would you like to edit the assignment narrative","YES","Y")
. . . . I DGASK<0 S DGABORT=1 Q ;abort edit action
. . . . I DGASK'=1 S DGQ=1 Q
. . . ;
. . . ;--edit narrative - only '5;Entered in Error' Required
. . . ;--edit the assignment narrative
. . . S DGAROOT=$$GET1^DIQ(26.13,DGIEN,"1","Z",DGAROOT)
. . . S DIC=$$OREF^DILF(DGAROOT)
. . . S DIWETXT="Patient Record Flag - Assignment Narrative Text"
. . . S DIWESUB="Assignment Narrative Text"
. . . S DWLW=75 ;max # of chars allowed to be stored on WP global node
. . . S DWPK=1 ;if line editor, don't join lines
. . . D EN^DIWE
. . . I '$$CKWP^DGPFUT(DGAROOT,.DGTX) D Q
. . . . W !,"Assignment Narrative Text is required!"_$C(7)
. . . . I $D(DGTX) S I=0 F S I=$O(DGTX(I)) Q:'I W !,DGTX(I)
. . . . I '$$CONTINUE^DGPFUT() S DGABORT=1
. . . . Q
. . . ; if number of text lines not the same, a change was made
. . . I $O(DGPFA("NARR",""),-1)'=$O(@DGAROOT@(""),-1) S DGOK=1 Q
. . . ; now check for a difference in text line content
. . . S DGSUB=0
. . . F S DGSUB=$O(DGPFA("NARR",DGSUB)) Q:DGSUB="" D Q:DGOK
. . . . I DGPFA("NARR",DGSUB,0)'=@DGAROOT@(DGSUB,0) S DGOK=1
. . . Q:DGOK
. . . I 'DGOK,$$EIE D Q ;required edit
. . . . W !!,"No editing was found to the Narrative text."
. . . . W !,"For 'Entered in Error' Action, you must edit the Assignment Narrative Text."_$C(7),!
. . . . I '$$CONTINUE^DGPFUT() S DGABORT=1
. . . S DGOK=1
. . . Q
. . Q
. ;
. Q:$G(DGABORT)
. ;
. ;if narrative edited, place new narrative into DGPFA array
. I $G(DGOK) D
. . K DGPFA("NARR") ;remove old narrative text
. . M DGPFA("NARR")=@DGAROOT K @DGAROOT
. ;
. ;prompt user for 'Approved By' person, quit if not selected
. S DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ")
. Q:(DGPFAH("APPRVBY")'>0)
. ;
. ;have user enter the edit reason/history comments (required)
. ;quit if required edit reason/history comments not entered
. S (DGABORT,DGOK)=0
. F D Q:(DGOK!DGABORT)
. . N I,DGTX,DIC,DIWESUB,DIWETXT,DWLW,DWPK
. . W !!,"Enter the reason for editing this assignment:" ;needed for line editor
. . S DIC=$$OREF^DILF(DGCROOT)
. . S DIWETXT="Patient Record Flag - Edit Reason Text"
. . S DIWESUB="Edit Reason Text"
. . S DWLW=75 ;max # of chars allowed to be stored on WP global node
. . S DWPK=1 ;if line editor, don't join lines
. . D EN^DIWE
. . I $$CKWP^DGPFUT(DGCROOT,.DGTX) S DGOK=1
. . E D
. . . W !,"Edit Reason is required!"_$C(7)
. . . I $D(DGTX) S I=0 F S I=$O(DGTX(I)) Q:'I W !,DGTX(I)
. . . I '$$CONTINUE^DGPFUT() S DGABORT=1
. . . Q
. . Q
. ;
. ;quit if required edit reason/history comments not entered
. Q:$G(DGABORT)
. ;
. ; place comments into history array
. I 'DGABORT M DGPFAH("COMMENT")=@DGCROOT K @DGCROOT
. ;
. ;setup remaining assignment history nodes for filing
. S DGPFAH("ASSIGNDT")=$$NOW^XLFDT ;current date/time
. S DGPFAH("ENTERBY")=DUZ ;current user
. S DGPFAH("ORIGFAC")=+$$SITE^VASITE ;DG 1106 site entering action
. ;
. ;calculate the default review date
. S DGRDAT=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
. ;
. ;prompt for review date when valid default review date and ACTIVE
. ;status, otherwise null
. ; DG*3.5*951 - for new X action, no review date changes
. ; move pre-DG*5.3*951 code inside first argumentless DO
. I DGPFAH("ACTION")<6 D
. . I DGRDAT>0,DGPFA("STATUS")=1 D
. . . N Y,XDT S Y=$$FMTE^XLFDT(DGRDAT,"5D")
. . . S XDT="D^"_DT_":"_DGRDAT_":EX"
. . . S DGPFA("REVIEWDT")=$$ANSWER^DGPFUT("Enter Review Date",Y,XDT)
. . . Q
. . E S DGPFA("REVIEWDT")=""
. . Q
. Q:DGPFA("REVIEWDT")<0
. ;
. ;DG*5.3*951 - update DGPFA() and DGPFAH() as appropriate
. I $$EIE D EIEARR
. S DGPFA("ACTION")=$P(DGPFAH("ACTION"),U)
. ;
. ;display flag assignment review screen to user
. D REVIEW^DGPFUT3(.DGPFA,.DGPFAH,DGIEN,XQY0,XQORNOD(0))
. ;
. ;if EIE,Behavioral flag, display warning ; DG*5.3*951
. I $$EIE,$$BEH D EIE^DGPFUT6(.DGPFAH)
. ;
. Q:$$ANSWER^DGPFUT("Would you like to file the assignment changes","YES","Y")'>0
. ;
. ;file the assignment and history using STOALL api
. W !,"Updating the patient's record flag assignment..."
. S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR,"D")
. S X="Assignment was "_$S('DGRESULT:"not ",1:"")_"filed successfully."
. W !?5,X
. ;
. ;send HL7 message if editing assignment to a CAT I flag
. I DGRESULT,DGPFA("FLAG")["26.15",$$SNDORU^DGPFHLS(+DGRESULT) D
. . W !?5,"Message sent...updating patient's sites of record."
. . Q
. ;
. D PAUSE^VALM1
. ;re-build list of flag assignments for patient
. D BLDLIST^DGPFLMU(DGDFN)
. Q
;
;release lock after edit
D UNLOCK^DGPFAA3(DGIEN)
;
;return to LM (refresh screen)
S VALMBCK="R"
;
Q
;
BEH() ;
N X,Y S X=$G(DGPFA("FLAG"))
S Y=0 I X[26.15,$P(X,U,2)="BEHAVIORAL" S Y=1
Q Y
;
EIE() ; was this action ENTERED IN ERROR
Q +$G(DGPFAH("ACTION"))=5
;
EIEARR ;
; Reset DGPFA() and DGPFAH() for DBRS EIE action
N I,J,X,Y
K DGPFAH("DBRS")
S (I,J)=0 F S I=$O(DGPFA("DBRS#",I)) Q:'I D
. S X=$P(DGPFA("DBRS#",I),U)
. S $P(X,U,2)=$P($G(DGPFA("DBRS OTHER",I)),U)
. S $P(X,U,3)=$P($G(DGPFA("DBRS DATE",I)),U)
. S $P(X,U,4)="D"
. S $P(X,U,5)=$P($G(DGPFA("DBRS SITE",I)),U)
. S J=J+1,DGPFAH("DBRS",J)=X
. Q
F Y="DBRS#","DBRS DATE","DBRS OTHER","DBRS SITE" K DGPFA(Y)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFLMA3 10725 printed Dec 13, 2024@02:48:13 Page 2
DGPFLMA3 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 6/2/05 3:24pm
+1 ;;5.3;Registration;**425,623,554,650,864,951,1106**;Aug 13, 1993;Build 1
+2 ; Last Edited: SHRPE/SGM - Sep 25, 2018 17:31
+3 ;NOTES:
+4 ; 1/23/2018 - with addition of DBRS, when to not complete action
+5 ; changes from previous version. One can edit DBRS#
+6 ; only with no other changes.
+7 ; ICR# TYPE DESCRIPTION
+8 ;----- ---- -------------------------------
+9 ; 2050 Sup ^DIALOG: BLD, MSG
+10 ; 2051 Sup UPDATE^DIE
+11 ; 2054 Sup $$OREF^DILF
+12 ; 2056 Sup $$GET1^DIQ
+13 ;10028 Sup EN^DIWE
+14 ;10060 Sup File 200 FM read of all fields
+15 ;10103 Sup ^XLFDT: $$FMTE, $$NOW
+16 ;10113 Sup ^DIK
+17 ;10116 Sup ^VALM1: FULL, PAUSE
+18 ;10119 Sup EN^VALM2
+19 ;
+20 QUIT
+21 ;
EF ;Entry point for DGPF EDIT ASSIGNMENT action protocol.
+1 ;
+2 ; Input: None
+3 ;
+4 ; Output:
+5 ; VALMBCK - 'R' = refresh screen
+6 ;
+7 ;input vars for EN^DIWE call
+8 NEW X,Y,DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DWPK
+9 ;assignment narrative word processing root
NEW DGAROOT
+10 ;assignment history comment word processing root
NEW DGCROOT
+11 ;abort flag for entering assignment narrative
NEW DGABORT
+12 ;return value from $$ANSWER^DGPFUT call
NEW DGASK
+13 ;ok flag for entering assignment narrative
NEW DGOK
+14 ;action code
NEW DGCODE
+15 ;pointer to patient in PATIENT (#2) file
NEW DGDFN
+16 ;assignment ien
NEW DGIEN
+17 ;assignment array
NEW DGPFA
+18 ;assignment history array
NEW DGPFAH
+19 ;if error returned from STOALL api call
NEW DGPFERR
+20 ;quit var for narrative edit
NEW DGQ
+21 ;review date
NEW DGRDAT
+22 ;result of STOALL api call
NEW DGRESULT
+23 ;error if unable to edit assignment
NEW DGERR
+24 ;error text
NEW DGETEXT
+25 ;for loop var
NEW DGSUB
+26 ;user selection (list item)
NEW SEL
+27 ;output of EN^VALM2 call, array of user selected entries
NEW VALMY
+28 ;
+29 ;set screen to full scroll region
+30 DO FULL^VALM1
+31 ;
+32 ;quit if selected action is not appropriate
+33 IF '$DATA(@VALMAR@("IDX"))
Begin DoDot:1
+34 IF '$GET(DGDFN)
SET DGETEXT(1)="Patient has not been selected."
+35 IF '$TEST
SET DGETEXT(1)="Patient has no record flag assignments."
+36 DO BLD^DIALOG(261129,.DGETEXT,"","DGERR","F")
+37 DO MSG^DIALOG("WE","","","","DGERR")
WRITE $CHAR(7)
+38 DO PAUSE^VALM1
+39 SET VALMBCK="R"
End DoDot:1
QUIT
+40 ;
+41 ;allow user to select a SINGLE flag assignment for editing
+42 SET (DGIEN,VALMBCK)=""
+43 DO EN^VALM2($GET(XQORNOD(0)),"S")
+44 ;
+45 ;process user selection
+46 SET SEL=$ORDER(VALMY(""))
+47 IF SEL
IF $DATA(@VALMAR@("IDX",SEL,SEL))
Begin DoDot:1
+48 NEW X
+49 SET DGIEN=$PIECE($GET(@VALMAR@("IDX",SEL,SEL)),U)
+50 SET DGDFN=$PIECE($GET(@VALMAR@("IDX",SEL,SEL)),U,2)
+51 ;
+52 ;attempt to obtain lock on assignment record
+53 IF '$$LOCK^DGPFAA3(DGIEN)
Begin DoDot:2
+54 WRITE !!,"Record flag assignment currently in use, cannot be edited!"
+55 DO PAUSE^VALM1
End DoDot:2
QUIT
+56 ;
+57 ;init word processing arrays
+58 SET DGAROOT=$NAME(^TMP($JOB,"DGPFNARR"))
+59 SET DGCROOT=$NAME(^TMP($JOB,"DGPFCMNT"))
+60 KILL @DGAROOT,@DGCROOT
+61 ;
+62 ;get assignment into DGPFA array
+63 IF '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1)
Begin DoDot:2
+64 WRITE !!,"Unable to retrieve the record flag assignment selected."
+65 DO PAUSE^VALM1
End DoDot:2
QUIT
+66 ;
+67 ;urgent address as female flag can't be edited dg*5.3*864
+68 IF $PIECE(DGPFA("FLAG"),",",2)="^URGENT ADDRESS AS FEMALE"
Begin DoDot:2
+69 WRITE !!
+70 WRITE !!,"The URGENT ADDRESS AS FEMALE Flag assignment cannot be edited."
+71 WRITE !!
+72 DO PAUSE^VALM1
End DoDot:2
QUIT
+73 ;
+74 ;is assignment edit allowed?
+75 IF '$$EDTOK^DGPFAA2(.DGPFA,DUZ(2),"DGERR")
Begin DoDot:2
+76 WRITE !!,"Assignment can not be edited..."
+77 DO MSG^DIALOG("WE","","",5,"DGERR")
+78 DO PAUSE^VALM1
End DoDot:2
QUIT
+79 ;
+80 ;-if assignment is active, set available action codes to Continue
+81 ; and Inactivate; else set code to Reactivate
+82 ;-if Local Flag or PRF Phase 2 active, add Entered in Error code
+83 ;-dg*951 - add DBRS edit option. This action is worded to allow
+84 ; for future fields to be added without having to add new
+85 ; actions. DBRS edit action only available on actions Continue
+86 ; and Reactivate
+87 IF +DGPFA("STATUS")=1
Begin DoDot:2
+88 SET DGCODE="S^C:Continue Assignment;I:Inactivate Assignment"
+89 IF $$P2ON^DGPFPARM()!(DGPFA("FLAG")["26.11")
SET DGCODE=DGCODE_";E:Entered in Error"
+90 ; dg*5.3*951
IF $PIECE(DGPFA("FLAG"),U,2)="BEHAVIORAL"
Begin DoDot:3
+91 SET DGCODE=DGCODE_";X:DBRS/Other Field Edit Only"
+92 QUIT
End DoDot:3
+93 QUIT
End DoDot:2
+94 IF '$TEST
SET DGCODE="S^R:Reactivate Assignment"
+95 ;
+96 ;prompt user for assignment action, quit if no action selected
+97 ;"ACTION" will have a value from 1-6 ; dg*951
+98 SET X=$$ANSWER^DGPFUT("Select an assignment action","",DGCODE)
+99 if (X=-1)
QUIT
+100 SET X=$FIND("CIREX",X)
if 'X
QUIT
SET DGPFAH("ACTION")=X
+101 ;
+102 ;if assignment action is 'Inactivate' or 'Entered in Error',
+103 ;set status to 'Inactive'. default='Active'
+104 ;if action is DBRS do not change current status; DG*5.3*951
+105 IF DGPFAH("ACTION")'=6
Begin DoDot:2
+106 SET DGPFA("STATUS")=$SELECT(DGPFAH("ACTION")=3:0,DGPFAH("ACTION")=5:0,1:1)
+107 QUIT
End DoDot:2
+108 ;
+109 ; DBRS ; DG*5.3*951
+110 IF $$BEH
IF '$$EIE
IF '$$DBRSEDIT^DGPFUT6
QUIT
+111 ;
+112 ;if action is not 'Inactivate', then prompt user to edit the narr
+113 SET (DGABORT,DGOK,DGQ)=0
+114 IF 36'[DGPFAH("ACTION")
Begin DoDot:2
+115 FOR
Begin DoDot:3
+116 NEW I,DGTX
+117 ; if action code not 'Entered in Error', can't force edit
+118 IF '$$EIE
Begin DoDot:4
+119 SET DGASK=$$ANSWER^DGPFUT("Would you like to edit the assignment narrative","YES","Y")
+120 ;abort edit action
IF DGASK<0
SET DGABORT=1
QUIT
+121 IF DGASK'=1
SET DGQ=1
QUIT
End DoDot:4
if (DGQ!DGABORT)
QUIT
+122 ;
+123 ;--edit narrative - only '5;Entered in Error' Required
+124 ;--edit the assignment narrative
+125 SET DGAROOT=$$GET1^DIQ(26.13,DGIEN,"1","Z",DGAROOT)
+126 SET DIC=$$OREF^DILF(DGAROOT)
+127 SET DIWETXT="Patient Record Flag - Assignment Narrative Text"
+128 SET DIWESUB="Assignment Narrative Text"
+129 ;max # of chars allowed to be stored on WP global node
SET DWLW=75
+130 ;if line editor, don't join lines
SET DWPK=1
+131 DO EN^DIWE
+132 IF '$$CKWP^DGPFUT(DGAROOT,.DGTX)
Begin DoDot:4
+133 WRITE !,"Assignment Narrative Text is required!"_$CHAR(7)
+134 IF $DATA(DGTX)
SET I=0
FOR
SET I=$ORDER(DGTX(I))
if 'I
QUIT
WRITE !,DGTX(I)
+135 IF '$$CONTINUE^DGPFUT()
SET DGABORT=1
+136 QUIT
End DoDot:4
QUIT
+137 ; if number of text lines not the same, a change was made
+138 IF $ORDER(DGPFA("NARR",""),-1)'=$ORDER(@DGAROOT@(""),-1)
SET DGOK=1
QUIT
+139 ; now check for a difference in text line content
+140 SET DGSUB=0
+141 FOR
SET DGSUB=$ORDER(DGPFA("NARR",DGSUB))
if DGSUB=""
QUIT
Begin DoDot:4
+142 IF DGPFA("NARR",DGSUB,0)'=@DGAROOT@(DGSUB,0)
SET DGOK=1
End DoDot:4
if DGOK
QUIT
+143 if DGOK
QUIT
+144 ;required edit
IF 'DGOK
IF $$EIE
Begin DoDot:4
+145 WRITE !!,"No editing was found to the Narrative text."
+146 WRITE !,"For 'Entered in Error' Action, you must edit the Assignment Narrative Text."_$CHAR(7),!
+147 IF '$$CONTINUE^DGPFUT()
SET DGABORT=1
End DoDot:4
QUIT
+148 SET DGOK=1
+149 QUIT
End DoDot:3
if (DGOK!DGABORT!DGQ)
QUIT
+150 QUIT
End DoDot:2
+151 ;
+152 if $GET(DGABORT)
QUIT
+153 ;
+154 ;if narrative edited, place new narrative into DGPFA array
+155 IF $GET(DGOK)
Begin DoDot:2
+156 ;remove old narrative text
KILL DGPFA("NARR")
+157 MERGE DGPFA("NARR")=@DGAROOT
KILL @DGAROOT
End DoDot:2
+158 ;
+159 ;prompt user for 'Approved By' person, quit if not selected
+160 SET DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ")
+161 if (DGPFAH("APPRVBY")'>0)
QUIT
+162 ;
+163 ;have user enter the edit reason/history comments (required)
+164 ;quit if required edit reason/history comments not entered
+165 SET (DGABORT,DGOK)=0
+166 FOR
Begin DoDot:2
+167 NEW I,DGTX,DIC,DIWESUB,DIWETXT,DWLW,DWPK
+168 ;needed for line editor
WRITE !!,"Enter the reason for editing this assignment:"
+169 SET DIC=$$OREF^DILF(DGCROOT)
+170 SET DIWETXT="Patient Record Flag - Edit Reason Text"
+171 SET DIWESUB="Edit Reason Text"
+172 ;max # of chars allowed to be stored on WP global node
SET DWLW=75
+173 ;if line editor, don't join lines
SET DWPK=1
+174 DO EN^DIWE
+175 IF $$CKWP^DGPFUT(DGCROOT,.DGTX)
SET DGOK=1
+176 IF '$TEST
Begin DoDot:3
+177 WRITE !,"Edit Reason is required!"_$CHAR(7)
+178 IF $DATA(DGTX)
SET I=0
FOR
SET I=$ORDER(DGTX(I))
if 'I
QUIT
WRITE !,DGTX(I)
+179 IF '$$CONTINUE^DGPFUT()
SET DGABORT=1
+180 QUIT
End DoDot:3
+181 QUIT
End DoDot:2
if (DGOK!DGABORT)
QUIT
+182 ;
+183 ;quit if required edit reason/history comments not entered
+184 if $GET(DGABORT)
QUIT
+185 ;
+186 ; place comments into history array
+187 IF 'DGABORT
MERGE DGPFAH("COMMENT")=@DGCROOT
KILL @DGCROOT
+188 ;
+189 ;setup remaining assignment history nodes for filing
+190 ;current date/time
SET DGPFAH("ASSIGNDT")=$$NOW^XLFDT
+191 ;current user
SET DGPFAH("ENTERBY")=DUZ
+192 ;DG 1106 site entering action
SET DGPFAH("ORIGFAC")=+$$SITE^VASITE
+193 ;
+194 ;calculate the default review date
+195 SET DGRDAT=$$GETRDT^DGPFAA3($PIECE(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
+196 ;
+197 ;prompt for review date when valid default review date and ACTIVE
+198 ;status, otherwise null
+199 ; DG*3.5*951 - for new X action, no review date changes
+200 ; move pre-DG*5.3*951 code inside first argumentless DO
+201 IF DGPFAH("ACTION")<6
Begin DoDot:2
+202 IF DGRDAT>0
IF DGPFA("STATUS")=1
Begin DoDot:3
+203 NEW Y,XDT
SET Y=$$FMTE^XLFDT(DGRDAT,"5D")
+204 SET XDT="D^"_DT_":"_DGRDAT_":EX"
+205 SET DGPFA("REVIEWDT")=$$ANSWER^DGPFUT("Enter Review Date",Y,XDT)
+206 QUIT
End DoDot:3
+207 IF '$TEST
SET DGPFA("REVIEWDT")=""
+208 QUIT
End DoDot:2
+209 if DGPFA("REVIEWDT")<0
QUIT
+210 ;
+211 ;DG*5.3*951 - update DGPFA() and DGPFAH() as appropriate
+212 IF $$EIE
DO EIEARR
+213 SET DGPFA("ACTION")=$PIECE(DGPFAH("ACTION"),U)
+214 ;
+215 ;display flag assignment review screen to user
+216 DO REVIEW^DGPFUT3(.DGPFA,.DGPFAH,DGIEN,XQY0,XQORNOD(0))
+217 ;
+218 ;if EIE,Behavioral flag, display warning ; DG*5.3*951
+219 IF $$EIE
IF $$BEH
DO EIE^DGPFUT6(.DGPFAH)
+220 ;
+221 if $$ANSWER^DGPFUT("Would you like to file the assignment changes","YES","Y")'>0
QUIT
+222 ;
+223 ;file the assignment and history using STOALL api
+224 WRITE !,"Updating the patient's record flag assignment..."
+225 SET DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR,"D")
+226 SET X="Assignment was "_$SELECT('DGRESULT:"not ",1:"")_"filed successfully."
+227 WRITE !?5,X
+228 ;
+229 ;send HL7 message if editing assignment to a CAT I flag
+230 IF DGRESULT
IF DGPFA("FLAG")["26.15"
IF $$SNDORU^DGPFHLS(+DGRESULT)
Begin DoDot:2
+231 WRITE !?5,"Message sent...updating patient's sites of record."
+232 QUIT
End DoDot:2
+233 ;
+234 DO PAUSE^VALM1
+235 ;re-build list of flag assignments for patient
+236 DO BLDLIST^DGPFLMU(DGDFN)
+237 QUIT
End DoDot:1
+238 ;
+239 ;release lock after edit
+240 DO UNLOCK^DGPFAA3(DGIEN)
+241 ;
+242 ;return to LM (refresh screen)
+243 SET VALMBCK="R"
+244 ;
+245 QUIT
+246 ;
BEH() ;
+1 NEW X,Y
SET X=$GET(DGPFA("FLAG"))
+2 SET Y=0
IF X[26.15
IF $PIECE(X,U,2)="BEHAVIORAL"
SET Y=1
+3 QUIT Y
+4 ;
EIE() ; was this action ENTERED IN ERROR
+1 QUIT +$GET(DGPFAH("ACTION"))=5
+2 ;
EIEARR ;
+1 ; Reset DGPFA() and DGPFAH() for DBRS EIE action
+2 NEW I,J,X,Y
+3 KILL DGPFAH("DBRS")
+4 SET (I,J)=0
FOR
SET I=$ORDER(DGPFA("DBRS#",I))
if 'I
QUIT
Begin DoDot:1
+5 SET X=$PIECE(DGPFA("DBRS#",I),U)
+6 SET $PIECE(X,U,2)=$PIECE($GET(DGPFA("DBRS OTHER",I)),U)
+7 SET $PIECE(X,U,3)=$PIECE($GET(DGPFA("DBRS DATE",I)),U)
+8 SET $PIECE(X,U,4)="D"
+9 SET $PIECE(X,U,5)=$PIECE($GET(DGPFA("DBRS SITE",I)),U)
+10 SET J=J+1
SET DGPFAH("DBRS",J)=X
+11 QUIT
End DoDot:1
+12 FOR Y="DBRS#","DBRS DATE","DBRS OTHER","DBRS SITE"
KILL DGPFA(Y)
+13 QUIT
