- 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 Feb 19, 2025@00:14:15 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