Routine: DGPFLMA4

DGPFLMA4 ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 10/18/06 9:41am

 ;;5.3;Registration;**425,554,650,951,1113**;Aug 13, 1993;Build 10

 ;no direct entry

CO ;Entry point for DGPF CHANGE ASSIGNMENT OWNERSHIP action protocol.

 ;  Input: None

 ; Output:

 ;   VALMBCK - 'R' = refresh screen

 N DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DDWC,DWPK  ;input vars for EN^DIWE

 N DGCROOT  ;assignment history comment word processing root

 N DGABORT  ;abort flag for entering assignment narrative

 N DGOK     ;ok flag for entering assignment narrative

 N DGIEN    ;assignment ien

 N DGINST   ;institution ien

 N DGPFA    ;assignment array

 N DGPFAH   ;assignment history array

 N DGRESULT ;result of STOALL api call

 N DGERR    ;error if unable to edit assignment

 N DGETEXT  ;error text

 N DGPFERR  ;if error returned from STOALL api call

 N DGOWN    ;valid owner list array

 N SEL      ;user selection (list item)

 N VALMY    ;output of EN^VALM2 call, array of user selected entries

 N DBRSDATA ;array containing DBRS data from file 26.13

 N DBRSCNT  ;DBRS counter

 N DBRSNUM  ;DBRS #

 ; set screen to full scroll region

 D FULL^VALM1

 ; quit if selected action is not appropriate

 I '$D(@VALMAR@("IDX")) D  Q

 .S DGETEXT(1)="Patient has no record flag assignments."

 .I '$G(DGDFN) S DGETEXT(1)="Patient has not been selected."

 .D BLD^DIALOG(261129,.DGETEXT,"","DGERR","F")

 .D MSG^DIALOG("WE","","","","DGERR") W *7

 .D PAUSE^VALM1

 .S VALMBCK="R"

.Q

 ; allow user to select a SINGLE flag assignment for ownership change

 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

 .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, can not be edited!",*7

 ..D PAUSE^VALM1

..Q

 .; get assignment into DGPFA array

 .I '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1) D  Q

 ..W !!,"Unable to retrieve the record flag assignment selected.",*7

 ..D PAUSE^VALM1

..Q

 .; check for pending transfer requests

 .I $O(^DGPF(26.22,"D",DGDFN,$P($P(DGPFA("FLAG"),U),";"),2,""))'="" D  Q

 ..W !!,"Please review active FT request to complete ownership transfer.",*7

 ..D PAUSE^VALM1

..Q

 .; can site change ownership of the assignment?

 .I '$$CHGOWN^DGPFAA2(.DGPFA,$G(DUZ(2)),"DGERR") D  Q

 ..W !!,"Changing the ownership of this record flag assignment not allowed...",*7

 ..D MSG^DIALOG("WE","","",5,"DGERR")

 ..D PAUSE^VALM1

..Q

 .; prompt for new OWNER SITE of the assignment

.;

 .;-create selection list of enabled division owners

 .S DGINST=0 F  S DGINST=$O(^DG(40.8,"APRF",DGINST)) Q:'DGINST  D

 ..I $$TF^XUAF4(DGINST) S DGOWN(DGINST)=""

..Q

 .;-add treating facilities to selection list for Cat I assignments

 .I $G(DGPFA("FLAG"))["26.15",$$BLDTFL^DGPFUT2(DGDFN,.DGOWN)

 .;-remove existing owner from selection list

 .K DGOWN(+$G(DGPFA("OWNER")))

.;

 .S DGPFA("OWNER")=$$ANSWER^DGPFUT("Select new owner site for this record flag assignment","","P^4:EMZ","","I $D(DGOWN(+Y))")

 .Q:(DGPFA("OWNER")'>0)

 .; prompt for APPROVED BY person

 .S DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ")

 .Q:(DGPFAH("APPRVBY")'>0)

 .; allow user to enter HISTORY COMMENTS (edit reason)

 .S DGCROOT=$NA(^TMP($J,"DGPFCMNT"))  ;init WP array for hist comments

 .K @DGCROOT

 .S (DGABORT,DGOK)=0

 .F  D  Q:(DGOK!DGABORT)

 ..W !!,"Enter the reason for editing this assignment:"  ;needed for line editor

 ..S @DGCROOT@(1,0)="Change of flag assignment ownership.  "

 ..S DIC=$$OREF^DILF(DGCROOT)

 ..S DIWETXT="Enter the reason for record flag assignment ownership change:"

 ..S DIWESUB="Change of Ownership Reason"

 ..S DWLW=75   ;max # of chars allowed to be stored on WP global node

 ..S DWPK=1    ;if line editor, don't join lines

 ..S DDWC="E"  ;initially place cursor at end of line 1

 ..D EN^DIWE

 ..I $$CKWP^DGPFUT(DGCROOT) S DGOK=1 Q

 ..W !,"The reason for editing this record flag assignment is required!",*7

 ..I '$$CONTINUE^DGPFUT() S DGABORT=1

..Q

 .; quit if required HISTORY COMMENTS not entered

 .Q:$G(DGABORT)

 .; place HISTORY COMMENTS into history array

 .M DGPFAH("COMMENT")=@DGCROOT K @DGCROOT

 .; setup remaining assignment history array nodes for filing

 .S DGPFAH("ACTION")=2                ;continue

 .S DGPFAH("ASSIGNDT")=$$NOW^XLFDT()  ;current date/time

 .S DGPFAH("ENTERBY")=DUZ             ;current user

 .S DGPFAH("ORIGFAC")=+$$SITE^VASITE

 .; relinquishing ownership should remove existing review date when

 .; new owner is not a local division

 .I '$D(^DG(40.8,"APRF",DGPFA("OWNER"))) S DGPFA("REVIEWDT")=""

 .; add DBRS data to DGPFAH array

 .D GETDBRS^DGPFUT6(.DBRSDATA,DGIEN)

 .S (DBRSCNT,DBRSNUM)=0 F  S DBRSNUM=$O(DBRSDATA(DBRSNUM)) Q:DBRSNUM=""  D

 ..S DBRSCNT=DBRSCNT+1

 ..S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$P($G(DBRSDATA(DBRSNUM,"OTHER")),U)_U_$P($G(DBRSDATA(DBRSNUM,"DATE")),U)

 ..S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"N"_U_$P($G(DBRSDATA(DBRSNUM,"SITE")),U)

..Q

 .; display flag assignment review screen to user

 .D REVIEW^DGPFUT3(.DGPFA,.DGPFAH,DGIEN,XQY0,XQORNOD(0))

 .; ask user if ok to file ownership change

 .Q:$$ANSWER^DGPFUT("Would you like to file the assignment ownership change","YES","Y")'>0

 .; file the assignment and history using STOALL api

 .W !!,"Updating the ownership of this patient's record flag assignment..."

 .S DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR,"")

 .W !?5,"Update was "_$S(+$G(DGRESULT):"successful",1:"not successful")_"."

 .; send HL7 ORU msg if editing assignment to a Cat I flag

 .I +$G(DGRESULT),$G(DGPFA("FLAG"))["26.15",$$SNDORU^DGPFHLS(+DGRESULT) W !?5,"Message sent...updating patient's sites of record."

 .D PAUSE^VALM1

 .; rebuild list of flag assignments for patient

 .D BLDLIST^DGPFLMU(DGDFN)

 .; release lock after CO edit

 .D UNLOCK^DGPFAA3(DGIEN)

.Q

 ;return to LM (refresh screen)

 S VALMBCK="R"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFLMA4   6108     printed  Mar 13, 2025@21:52:47                                                                                                                                                                                                    Page 2

DGPFLMA4  ;ALB/KCL - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 10/18/06 9:41am

 +1       ;;5.3;Registration;**425,554,650,951,1113**;Aug 13, 1993;Build 10

 +2       ;

 +3       ;no direct entry

 +4        QUIT

 +5       ;

 +6       ;

CO        ;Entry point for DGPF CHANGE ASSIGNMENT OWNERSHIP action protocol.

 +1       ;

 +2       ;  Input: None

 +3       ;

 +4       ; Output:

 +5       ;   VALMBCK - 'R' = refresh screen

 +6       ;

 +7       ;input vars for EN^DIWE

           NEW DIC,DGWPROOT,DIWETXT,DIWESUB,DWLW,DDWC,DWPK

 +8       ;assignment history comment word processing root

           NEW DGCROOT

 +9       ;abort flag for entering assignment narrative

           NEW DGABORT

 +10      ;ok flag for entering assignment narrative

           NEW DGOK

 +11      ;assignment ien

           NEW DGIEN

 +12      ;institution ien

           NEW DGINST

 +13      ;assignment array

           NEW DGPFA

 +14      ;assignment history array

           NEW DGPFAH

 +15      ;result of STOALL api call

           NEW DGRESULT

 +16      ;error if unable to edit assignment

           NEW DGERR

 +17      ;error text

           NEW DGETEXT

 +18      ;if error returned from STOALL api call

           NEW DGPFERR

 +19      ;valid owner list array

           NEW DGOWN

 +20      ;user selection (list item)

           NEW SEL

 +21      ;output of EN^VALM2 call, array of user selected entries

           NEW VALMY

 +22      ;array containing DBRS data from file 26.13

           NEW DBRSDATA

 +23      ;DBRS counter

           NEW DBRSCNT

 +24      ;DBRS #

           NEW DBRSNUM

 +25      ;

 +26      ; set screen to full scroll region

 +27       DO FULL^VALM1

 +28      ; quit if selected action is not appropriate

 +29       IF '$DATA(@VALMAR@("IDX"))

               Begin DoDot:1

 +30               SET DGETEXT(1)="Patient has no record flag assignments."

 +31               IF '$GET(DGDFN)

                       SET DGETEXT(1)="Patient has not been selected."

 +32               DO BLD^DIALOG(261129,.DGETEXT,"","DGERR","F")

 +33               DO MSG^DIALOG("WE","","","","DGERR")

                   WRITE *7

 +34               DO PAUSE^VALM1

 +35               SET VALMBCK="R"

 +36               QUIT

               End DoDot:1

               QUIT

 +37      ; allow user to select a SINGLE flag assignment for ownership change

 +38       SET (DGIEN,VALMBCK)=""

 +39       DO EN^VALM2($GET(XQORNOD(0)),"S")

 +40      ; process user selection

 +41       SET SEL=$ORDER(VALMY(""))

 +42       IF SEL

               IF $DATA(@VALMAR@("IDX",SEL,SEL))

                   Begin DoDot:1

 +43                   SET DGIEN=$PIECE($GET(@VALMAR@("IDX",SEL,SEL)),U)

 +44                   SET DGDFN=$PIECE($GET(@VALMAR@("IDX",SEL,SEL)),U,2)

 +45      ; attempt to obtain lock on assignment record

 +46                   IF '$$LOCK^DGPFAA3(DGIEN)

                           Begin DoDot:2

 +47                           WRITE !!,"Record flag assignment currently in use, can not be edited!",*7

 +48                           DO PAUSE^VALM1

 +49                           QUIT

                           End DoDot:2

                           QUIT

 +50      ; get assignment into DGPFA array

 +51                   IF '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1)

                           Begin DoDot:2

 +52                           WRITE !!,"Unable to retrieve the record flag assignment selected.",*7

 +53                           DO PAUSE^VALM1

 +54                           QUIT

                           End DoDot:2

                           QUIT

 +55      ; check for pending transfer requests

 +56                   IF $ORDER(^DGPF(26.22,"D",DGDFN,$PIECE($PIECE(DGPFA("FLAG"),U),";"),2,""))'=""

                           Begin DoDot:2

 +57                           WRITE !!,"Please review active FT request to complete ownership transfer.",*7

 +58                           DO PAUSE^VALM1

 +59                           QUIT

                           End DoDot:2

                           QUIT

 +60      ; can site change ownership of the assignment?

 +61                   IF '$$CHGOWN^DGPFAA2(.DGPFA,$GET(DUZ(2)),"DGERR")

                           Begin DoDot:2

 +62                           WRITE !!,"Changing the ownership of this record flag assignment not allowed...",*7

 +63                           DO MSG^DIALOG("WE","","",5,"DGERR")

 +64                           DO PAUSE^VALM1

 +65                           QUIT

                           End DoDot:2

                           QUIT

 +66      ; prompt for new OWNER SITE of the assignment

 +67      ;

 +68      ;-create selection list of enabled division owners

 +69                   SET DGINST=0

FOR

                           SET DGINST=$ORDER(^DG(40.8,"APRF",DGINST))

                           if 'DGINST

                               QUIT

                           Begin DoDot:2

 +70                           IF $$TF^XUAF4(DGINST)

                                   SET DGOWN(DGINST)=""

 +71                           QUIT

                           End DoDot:2

 +72      ;-add treating facilities to selection list for Cat I assignments

 +73                   IF $GET(DGPFA("FLAG"))["26.15"

                           IF $$BLDTFL^DGPFUT2(DGDFN,.DGOWN)

 +74      ;-remove existing owner from selection list

 +75                   KILL DGOWN(+$GET(DGPFA("OWNER")))

 +76      ;

 +77                   SET DGPFA("OWNER")=$$ANSWER^DGPFUT("Select new owner site for this record flag assignment","","P^4:EMZ","","I $D(DGOWN(+Y))")

 +78                   if (DGPFA("OWNER")'>0)

                           QUIT

 +79      ; prompt for APPROVED BY person

 +80                   SET DGPFAH("APPRVBY")=$$ANSWER^DGPFUT("Approved By","","P^200:EMZ")

 +81                   if (DGPFAH("APPRVBY")'>0)

                           QUIT

 +82      ; allow user to enter HISTORY COMMENTS (edit reason)

 +83      ;init WP array for hist comments

                       SET DGCROOT=$NAME(^TMP($JOB,"DGPFCMNT"))

 +84                   KILL @DGCROOT

 +85                   SET (DGABORT,DGOK)=0

 +86                   FOR

                           Begin DoDot:2

 +87      ;needed for line editor

                               WRITE !!,"Enter the reason for editing this assignment:"

 +88                           SET @DGCROOT@(1,0)="Change of flag assignment ownership.  "

 +89                           SET DIC=$$OREF^DILF(DGCROOT)

 +90                           SET DIWETXT="Enter the reason for record flag assignment ownership change:"

 +91                           SET DIWESUB="Change of Ownership Reason"

 +92      ;max # of chars allowed to be stored on WP global node

                               SET DWLW=75

 +93      ;if line editor, don't join lines

                               SET DWPK=1

 +94      ;initially place cursor at end of line 1

                               SET DDWC="E"

 +95                           DO EN^DIWE

 +96                           IF $$CKWP^DGPFUT(DGCROOT)

                                   SET DGOK=1

                                   QUIT

 +97                           WRITE !,"The reason for editing this record flag assignment is required!",*7

 +98                           IF '$$CONTINUE^DGPFUT()

                                   SET DGABORT=1

 +99                           QUIT

                           End DoDot:2

                           if (DGOK!DGABORT)

                               QUIT

 +100     ; quit if required HISTORY COMMENTS not entered

 +101                  if $GET(DGABORT)

                           QUIT

 +102     ; place HISTORY COMMENTS into history array

 +103                  MERGE DGPFAH("COMMENT")=@DGCROOT

                       KILL @DGCROOT

 +104     ; setup remaining assignment history array nodes for filing

 +105     ;continue

                       SET DGPFAH("ACTION")=2

 +106     ;current date/time

                       SET DGPFAH("ASSIGNDT")=$$NOW^XLFDT()

 +107     ;current user

                       SET DGPFAH("ENTERBY")=DUZ

 +108                  SET DGPFAH("ORIGFAC")=+$$SITE^VASITE

 +109     ; relinquishing ownership should remove existing review date when

 +110     ; new owner is not a local division

 +111                  IF '$DATA(^DG(40.8,"APRF",DGPFA("OWNER")))

                           SET DGPFA("REVIEWDT")=""

 +112     ; add DBRS data to DGPFAH array

 +113                  DO GETDBRS^DGPFUT6(.DBRSDATA,DGIEN)

 +114                  SET (DBRSCNT,DBRSNUM)=0

FOR

                           SET DBRSNUM=$ORDER(DBRSDATA(DBRSNUM))

                           if DBRSNUM=""

                               QUIT

                           Begin DoDot:2

 +115                          SET DBRSCNT=DBRSCNT+1

 +116                          SET DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$PIECE($GET(DBRSDATA(DBRSNUM,"OTHER")),U)_U_$PIECE($GET(DBRSDATA(DBRSNUM,"DATE")),U)

 +117                          SET DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"N"_U_$PIECE($GET(DBRSDATA(DBRSNUM,"SITE")),U)

 +118                          QUIT

                           End DoDot:2

 +119     ; display flag assignment review screen to user

 +120                  DO REVIEW^DGPFUT3(.DGPFA,.DGPFAH,DGIEN,XQY0,XQORNOD(0))

 +121     ; ask user if ok to file ownership change

 +122                  if $$ANSWER^DGPFUT("Would you like to file the assignment ownership change","YES","Y")'>0

                           QUIT

 +123     ; file the assignment and history using STOALL api

 +124                  WRITE !!,"Updating the ownership of this patient's record flag assignment..."

 +125                  SET DGRESULT=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGPFERR,"")

 +126                  WRITE !?5,"Update was "_$SELECT(+$GET(DGRESULT):"successful",1:"not successful")_"."

 +127     ; send HL7 ORU msg if editing assignment to a Cat I flag

 +128                  IF +$GET(DGRESULT)

                           IF $GET(DGPFA("FLAG"))["26.15"

                               IF $$SNDORU^DGPFHLS(+DGRESULT)

                                   WRITE !?5,"Message sent...updating patient's sites of record."

 +129                  DO PAUSE^VALM1

 +130     ; rebuild list of flag assignments for patient

 +131                  DO BLDLIST^DGPFLMU(DGDFN)

 +132     ; release lock after CO edit

 +133                  DO UNLOCK^DGPFAA3(DGIEN)

 +134                  QUIT

                   End DoDot:1

 +135     ;return to LM (refresh screen)

 +136      SET VALMBCK="R"

 +137     ;

 +138      QUIT

DGPFLMA4.m