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
Q
;
;
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"
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFLMA4 6108 printed Sep 23, 2025@20:24:06 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
