DGPFHLF ;SHRPE/SGM - PRF REFRESH ASSIGNMENT ; Aug 21, 2018 11:30
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
; Last edited: SHRPE/SGM - Nov 15,, 2018 14:25
;
QUIT
; ICR# TYPE DESCRIPTION
;----- ---- -------------------------
; 2056 Sup ^DIQ
; 3277 Sup OWNSKEY^XUSRB
;10103 Sup ^XLFDT: $$FMTE, $$NOW
;10112 Sup $$SITE^VASITE
;
RF ; Option: DGPF RECORD REFRESH
; .DGPFA() - contains the assignment data
; if Ownership failure choice selected then certain values may change
;
N I,J,X,NOW,SITE,TXT,USER
N DGIEN,DGPFA,DGPFAH,DGWHO,DGWHY
N DGAHIEN,DGERR,DGIEN,DGPFA,DGPFAH
; Introductory text
K TXT D TXT(.TXT,10,0,1)
W @IOF F I=1:1 Q:'$D(TXT(I)) W !,TXT(I)
W !
;
; Authorization check
Q:'$$CHECK
;
; select PRF Assignment
S DGIEN=$$SELASGN^DGPFUT6("I $P(^(0),U,2)[""(26.15,""")
Q:DGIEN<1
;
; attempt to obtain lock on assignment record
I '$$LOCK^DGPFAA3(DGIEN) D Q
. K TXT D TXT(.TXT,26,0,1) W !!,TXT(1)
. Q
;
; get assignment into DGPFA array
I '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1) D G OUT
. K TXT D TXT(.TXT,28,0,1) W !!,TXT(1)
. Q
;
; prompt for reason for doing refresh
; if OWNER SITE update needed, prompt for OWNER SITE value
S DGWHY=$$PROMPT I $S(DGWHY'?1U:1,1:"OU"'[DGWHY) G OUT
I DGWHY="O" D I DGWHO<1 G OUT
. S DGWHO=$$OWNER I DGWHO<1 Q
. I DGWHO=DGPFA("OWNER") Q
. S DGPFA("OWNER")=DGWHO
. I '$$ISDIV^DGPFUT(+DGWHO) S DGPFA("REVIEWDT")=""
. I '$D(^DG(40.8,"APRF",+DGWHO)) S DGPFA("REVIEWDT")=""
. Q
;
; add or rest some DGPFA()
S NOW=$$NOW^XLFDT,$P(NOW,U,2)=$$FMTE^XLFDT(+$E(NOW,1,12))
S SITE=$$SITE^VASITE
S USER=$$DIQ^DGPFUT(200,DUZ,.01)
S DGPFA("ACTION")=7+DGPFA("STATUS")
;
; build DGPFAH()
S DGPFAH("ASSIGN")=DGIEN_U_$P(DGPFA("DFN"),U,2)
S DGPFAH("ASSIGNDT")=+NOW
S DGPFAH("ACTION")=DGPFA("ACTION")
S DGPFAH("ENTERBY")=DUZ
S DGPFAH("APPRVBY")=DUZ
S DGPFAH("TIULINK")=""
S DGPFAH("ORIGFAC")=+SITE
;
K TXT D TXT(.TXT,1,1,0)
S $P(TXT(4,0),":",2)=" "_$P(SITE,U,2)
S $P(TXT(5,0),":",2)=" "_USER
S $P(TXT(6,0),":",2)=" "_$P(NOW,U,2)
M DGPFAH("COMMENT")=TXT
;
S J=0 F I=0:0 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,5)=$P($G(DGPFA("DBRS SITE",I)),U)
. S $P(X,U,4)="N"
. S J=J+1,DGPFAH("DBRS",J)=X
. Q
;
; Display flag assignment review screen to user
; 9/6/2018 - business analyst said to not show the display screen
; S X="DGPF FLAG ASSIGNMENT REFRESH"
; S X(0)="^^ASSIGNMENT REFRESH^"
; D REVIEW^DGPFUT3(.DGPFA,.DGPFAH,DGIEN,X,X(0))
;
; display message about the choices made
K TXT D TXT(.TXT,41,0,1)
W ! I DGWHY="O" W !,TXT(1),!,TXT(2)_$P(DGWHO,U,2)
W !,TXT(3),!,TXT(4),!
;
; prompt if which to continue
S X="Do you wish to send an HL7 update message now"
I $$ANSWER^DGPFUT(X,"NO","YO")<1 G OUT
;
; if refresh due to change of ownership update, then file assignment
K DGERR,TXT
D TXT(.TXT,46,0,1)
I +$G(DGWHO) D I $D(DGERR) G OUT
. D STOASGN^DGPFAA(.DGPFA,.DGERR,"D")
. I $D(DGERR) W !!,TXT(1),!,TXT(2),!
. Q
; create History record, display message if failed
W !!,TXT(3)
S DGAHIEN=$$STOHIST^DGPFAAH(.DGPFAH,.DGERR)
I $D(DGERR) W !,TXT(4),!,TXT(2) G OUT
;
; send HL7 update message to refresh assignment of a CAT I flag
S X=$$SNDORU^DGPFHLS(DGIEN) W ! W:X TXT(5) W:'X TXT(6)
;
OUT ;
; release lock
D UNLOCK^DGPFAA3(DGIEN)
W ! I $$ANSWER^DGPFUT("Press any key to continue",,"E")
Q
;
;---------------------------------------------------------------------
CHECK() ; validate user authorized to run this Option
N X,Y,DGRET,KEY,TXT
S KEY="DGPF TRANSMISSIONS"
D OWNSKEY^XUSRB(.DGRET,KEY,DUZ)
S Y=(DGRET(0)=1)
S X=($G(DUZ(0))="@")
I X,Y Q 1
D TXT(.TXT,8,0,1) W !!,TXT(1),!
Q 0
;
OWNER() ; prompt user for site to be assignment owner
; code copied from CHANGE OWNERSHIP action CO^DGPFLMA4
; do not remove current facility from list
N I,X,DFN,DGOWN,DIR0,DIRA,DIRS,DIV,TXT
S DFN=+DGPFA("DFN")
;
; add treating facilities to selection list for Cat I assignments
; display message if no other facilities found for patient
I '$$BLDTFL^DGPFUT2(DFN,.DGOWN) D Q 0
. D TXT(.TXT,36,0,1)
. W ! F I=1:1 Q:'$D(TXT(I)) W !,TXT(I)
. W !
. Q
S DIV=0 F I=0:0 S DIV=$O(^DG(40.8,"APRF",DIV)) Q:'DIV D
. I $$TF^XUAF4(DIV) S DGOWN(DIV)=""
. Q
;
S DIRA="Select new owner site for this record flag assignment"
S DIR0="P^4:EMZ"
S DIRS="I $D(DGOWN(+Y))"
W ! S X=$$ANSWER^DGPFUT(DIRA,,DIR0,,DIRS)
I X>0 S $P(X,U,2)=$$NAME^XUAF4(+X)
Q X
;
PROMPT() ; prompt user for reason for running this option
N X,DIR0,DIRA,DGDIRH,TXT
S DIR0="SO^U:Update failed;O:Ownership transfer failed"
S DIRA="Reason for refreshing data"
D TXT(.DGDIRH,30,0,1)
S DGDIRH=" "
S X=$$ANSWER^DGPFUT(DIRA,,DIR0,.DGDIRH)
Q X
;
TXT(TXT,ST,ZERO,PAD) ;
N I,J,X S J=0
F I=ST:1 S J=J+1,X=$P($T(T+I),";",3,99) Q:X?1"[end]".E D
. I $G(PAD) S X=" "_X
. I $G(ZERO) S TXT(J,0)=X
. E S TXT(J)=X
. Q
Q
;
T ;
1 ;;Updated PRF Assignment with the current data from this site.
;;This action will make all the recipients of the HL7 message to
;;update their assignment to exactly match the data in this message.
;; Originating Facility:
;; Updated By :
;; Date action taken :
;;[end]
8 ;;Sorry, you are not authorized to run this Option.
;;[end]
10 ;;This option is designed to resynchronize a Flag Assignment which has
;;differing values at various VAMC facilities where the patient has
;;been registered. The data on this system will be considered the
;;authorized source of that information for this flag assignment at
;;this time.
;;
;;Please make sure all the data associated with this Flag Assignment
;;is correct. If not, make those corrections before running this
;;option for all flag assignment fields except for the OWNER SITE
;;field.
;;
;;If you are running this option because a previous CHANGE OF
;;OWNERSHIP action failed to properly update all facilities, then this
;;option will prompt you for the name of that facility which is to be
;;the OWNER SITE for this flag assignment.
;;[end]
26 ;;Record flag assignment currently in use, cannot be edited!
;;[end]
28 ;;Unable to retrieve the record flag assignment selected.
;;[end]
30 ;;Enter the reason for exercising this option.
;;Enter 'O' if a change of ownership was done but some HL7 update
;; message failed resulting if various facilities having a different
;; value for the OWNER SITE field for this assignment.
;;Enter 'U' for all other reasons.
;;[end]
36 ;;Your TREATING FACILITY LIST file does not show any other VAMC
;;facilities as having registered this patient. Please use one of the
;;other Patient Record Flag options to correct the data for this flag
;;assignment.
;;[end]
41 ;;You have selected this Facility/Division as the OWNER SITE:
;;
;;This assignment will now be refreshed/resent to all sites where
;;this patient has been registered.
;;[end]
46 ;;PRF Assignment update for change of ownership failed.
;;No HL7 update messages were sent to the other sites.
;;Creating a PRF Assignment History record of this action.
;;PRF Assignment History record was not filed successfully.
;;HL7 message sent...updating patient's sites of record.
;;HL7 message **NOT** sent updating patient's sites of record.
;;[end]
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFHLF 7583 printed Sep 23, 2025@20:23:29 Page 2
DGPFHLF ;SHRPE/SGM - PRF REFRESH ASSIGNMENT ; Aug 21, 2018 11:30
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ; Last edited: SHRPE/SGM - Nov 15,, 2018 14:25
+3 ;
+4 QUIT
+5 ; ICR# TYPE DESCRIPTION
+6 ;----- ---- -------------------------
+7 ; 2056 Sup ^DIQ
+8 ; 3277 Sup OWNSKEY^XUSRB
+9 ;10103 Sup ^XLFDT: $$FMTE, $$NOW
+10 ;10112 Sup $$SITE^VASITE
+11 ;
RF ; Option: DGPF RECORD REFRESH
+1 ; .DGPFA() - contains the assignment data
+2 ; if Ownership failure choice selected then certain values may change
+3 ;
+4 NEW I,J,X,NOW,SITE,TXT,USER
+5 NEW DGIEN,DGPFA,DGPFAH,DGWHO,DGWHY
+6 NEW DGAHIEN,DGERR,DGIEN,DGPFA,DGPFAH
+7 ; Introductory text
+8 KILL TXT
DO TXT(.TXT,10,0,1)
+9 WRITE @IOF
FOR I=1:1
if '$DATA(TXT(I))
QUIT
WRITE !,TXT(I)
+10 WRITE !
+11 ;
+12 ; Authorization check
+13 if '$$CHECK
QUIT
+14 ;
+15 ; select PRF Assignment
+16 SET DGIEN=$$SELASGN^DGPFUT6("I $P(^(0),U,2)[""(26.15,""")
+17 if DGIEN<1
QUIT
+18 ;
+19 ; attempt to obtain lock on assignment record
+20 IF '$$LOCK^DGPFAA3(DGIEN)
Begin DoDot:1
+21 KILL TXT
DO TXT(.TXT,26,0,1)
WRITE !!,TXT(1)
+22 QUIT
End DoDot:1
QUIT
+23 ;
+24 ; get assignment into DGPFA array
+25 IF '$$GETASGN^DGPFAA(DGIEN,.DGPFA,1)
Begin DoDot:1
+26 KILL TXT
DO TXT(.TXT,28,0,1)
WRITE !!,TXT(1)
+27 QUIT
End DoDot:1
GOTO OUT
+28 ;
+29 ; prompt for reason for doing refresh
+30 ; if OWNER SITE update needed, prompt for OWNER SITE value
+31 SET DGWHY=$$PROMPT
IF $SELECT(DGWHY'?1U:1,1:"OU"'[DGWHY)
GOTO OUT
+32 IF DGWHY="O"
Begin DoDot:1
+33 SET DGWHO=$$OWNER
IF DGWHO<1
QUIT
+34 IF DGWHO=DGPFA("OWNER")
QUIT
+35 SET DGPFA("OWNER")=DGWHO
+36 IF '$$ISDIV^DGPFUT(+DGWHO)
SET DGPFA("REVIEWDT")=""
+37 IF '$DATA(^DG(40.8,"APRF",+DGWHO))
SET DGPFA("REVIEWDT")=""
+38 QUIT
End DoDot:1
IF DGWHO<1
GOTO OUT
+39 ;
+40 ; add or rest some DGPFA()
+41 SET NOW=$$NOW^XLFDT
SET $PIECE(NOW,U,2)=$$FMTE^XLFDT(+$EXTRACT(NOW,1,12))
+42 SET SITE=$$SITE^VASITE
+43 SET USER=$$DIQ^DGPFUT(200,DUZ,.01)
+44 SET DGPFA("ACTION")=7+DGPFA("STATUS")
+45 ;
+46 ; build DGPFAH()
+47 SET DGPFAH("ASSIGN")=DGIEN_U_$PIECE(DGPFA("DFN"),U,2)
+48 SET DGPFAH("ASSIGNDT")=+NOW
+49 SET DGPFAH("ACTION")=DGPFA("ACTION")
+50 SET DGPFAH("ENTERBY")=DUZ
+51 SET DGPFAH("APPRVBY")=DUZ
+52 SET DGPFAH("TIULINK")=""
+53 SET DGPFAH("ORIGFAC")=+SITE
+54 ;
+55 KILL TXT
DO TXT(.TXT,1,1,0)
+56 SET $PIECE(TXT(4,0),":",2)=" "_$PIECE(SITE,U,2)
+57 SET $PIECE(TXT(5,0),":",2)=" "_USER
+58 SET $PIECE(TXT(6,0),":",2)=" "_$PIECE(NOW,U,2)
+59 MERGE DGPFAH("COMMENT")=TXT
+60 ;
+61 SET J=0
FOR I=0:0
SET I=$ORDER(DGPFA("DBRS#",I))
if 'I
QUIT
Begin DoDot:1
+62 SET X=$PIECE(DGPFA("DBRS#",I),U)
+63 SET $PIECE(X,U,2)=$PIECE($GET(DGPFA("DBRS OTHER",I)),U)
+64 SET $PIECE(X,U,3)=$PIECE($GET(DGPFA("DBRS DATE",I)),U)
+65 SET $PIECE(X,U,5)=$PIECE($GET(DGPFA("DBRS SITE",I)),U)
+66 SET $PIECE(X,U,4)="N"
+67 SET J=J+1
SET DGPFAH("DBRS",J)=X
+68 QUIT
End DoDot:1
+69 ;
+70 ; Display flag assignment review screen to user
+71 ; 9/6/2018 - business analyst said to not show the display screen
+72 ; S X="DGPF FLAG ASSIGNMENT REFRESH"
+73 ; S X(0)="^^ASSIGNMENT REFRESH^"
+74 ; D REVIEW^DGPFUT3(.DGPFA,.DGPFAH,DGIEN,X,X(0))
+75 ;
+76 ; display message about the choices made
+77 KILL TXT
DO TXT(.TXT,41,0,1)
+78 WRITE !
IF DGWHY="O"
WRITE !,TXT(1),!,TXT(2)_$PIECE(DGWHO,U,2)
+79 WRITE !,TXT(3),!,TXT(4),!
+80 ;
+81 ; prompt if which to continue
+82 SET X="Do you wish to send an HL7 update message now"
+83 IF $$ANSWER^DGPFUT(X,"NO","YO")<1
GOTO OUT
+84 ;
+85 ; if refresh due to change of ownership update, then file assignment
+86 KILL DGERR,TXT
+87 DO TXT(.TXT,46,0,1)
+88 IF +$GET(DGWHO)
Begin DoDot:1
+89 DO STOASGN^DGPFAA(.DGPFA,.DGERR,"D")
+90 IF $DATA(DGERR)
WRITE !!,TXT(1),!,TXT(2),!
+91 QUIT
End DoDot:1
IF $DATA(DGERR)
GOTO OUT
+92 ; create History record, display message if failed
+93 WRITE !!,TXT(3)
+94 SET DGAHIEN=$$STOHIST^DGPFAAH(.DGPFAH,.DGERR)
+95 IF $DATA(DGERR)
WRITE !,TXT(4),!,TXT(2)
GOTO OUT
+96 ;
+97 ; send HL7 update message to refresh assignment of a CAT I flag
+98 SET X=$$SNDORU^DGPFHLS(DGIEN)
WRITE !
if X
WRITE TXT(5)
if 'X
WRITE TXT(6)
+99 ;
OUT ;
+1 ; release lock
+2 DO UNLOCK^DGPFAA3(DGIEN)
+3 WRITE !
IF $$ANSWER^DGPFUT("Press any key to continue",,"E")
+4 QUIT
+5 ;
+6 ;---------------------------------------------------------------------
CHECK() ; validate user authorized to run this Option
+1 NEW X,Y,DGRET,KEY,TXT
+2 SET KEY="DGPF TRANSMISSIONS"
+3 DO OWNSKEY^XUSRB(.DGRET,KEY,DUZ)
+4 SET Y=(DGRET(0)=1)
+5 SET X=($GET(DUZ(0))="@")
+6 IF X
IF Y
QUIT 1
+7 DO TXT(.TXT,8,0,1)
WRITE !!,TXT(1),!
+8 QUIT 0
+9 ;
OWNER() ; prompt user for site to be assignment owner
+1 ; code copied from CHANGE OWNERSHIP action CO^DGPFLMA4
+2 ; do not remove current facility from list
+3 NEW I,X,DFN,DGOWN,DIR0,DIRA,DIRS,DIV,TXT
+4 SET DFN=+DGPFA("DFN")
+5 ;
+6 ; add treating facilities to selection list for Cat I assignments
+7 ; display message if no other facilities found for patient
+8 IF '$$BLDTFL^DGPFUT2(DFN,.DGOWN)
Begin DoDot:1
+9 DO TXT(.TXT,36,0,1)
+10 WRITE !
FOR I=1:1
if '$DATA(TXT(I))
QUIT
WRITE !,TXT(I)
+11 WRITE !
+12 QUIT
End DoDot:1
QUIT 0
+13 SET DIV=0
FOR I=0:0
SET DIV=$ORDER(^DG(40.8,"APRF",DIV))
if 'DIV
QUIT
Begin DoDot:1
+14 IF $$TF^XUAF4(DIV)
SET DGOWN(DIV)=""
+15 QUIT
End DoDot:1
+16 ;
+17 SET DIRA="Select new owner site for this record flag assignment"
+18 SET DIR0="P^4:EMZ"
+19 SET DIRS="I $D(DGOWN(+Y))"
+20 WRITE !
SET X=$$ANSWER^DGPFUT(DIRA,,DIR0,,DIRS)
+21 IF X>0
SET $PIECE(X,U,2)=$$NAME^XUAF4(+X)
+22 QUIT X
+23 ;
PROMPT() ; prompt user for reason for running this option
+1 NEW X,DIR0,DIRA,DGDIRH,TXT
+2 SET DIR0="SO^U:Update failed;O:Ownership transfer failed"
+3 SET DIRA="Reason for refreshing data"
+4 DO TXT(.DGDIRH,30,0,1)
+5 SET DGDIRH=" "
+6 SET X=$$ANSWER^DGPFUT(DIRA,,DIR0,.DGDIRH)
+7 QUIT X
+8 ;
TXT(TXT,ST,ZERO,PAD) ;
+1 NEW I,J,X
SET J=0
+2 FOR I=ST:1
SET J=J+1
SET X=$PIECE($TEXT(T+I),";",3,99)
if X?1"[end]".E
QUIT
Begin DoDot:1
+3 IF $GET(PAD)
SET X=" "_X
+4 IF $GET(ZERO)
SET TXT(J,0)=X
+5 IF '$TEST
SET TXT(J)=X
+6 QUIT
End DoDot:1
+7 QUIT
+8 ;
T ;
1 ;;Updated PRF Assignment with the current data from this site.
+1 ;;This action will make all the recipients of the HL7 message to
+2 ;;update their assignment to exactly match the data in this message.
+3 ;; Originating Facility:
+4 ;; Updated By :
+5 ;; Date action taken :
+6 ;;[end]
8 ;;Sorry, you are not authorized to run this Option.
+1 ;;[end]
10 ;;This option is designed to resynchronize a Flag Assignment which has
+1 ;;differing values at various VAMC facilities where the patient has
+2 ;;been registered. The data on this system will be considered the
+3 ;;authorized source of that information for this flag assignment at
+4 ;;this time.
+5 ;;
+6 ;;Please make sure all the data associated with this Flag Assignment
+7 ;;is correct. If not, make those corrections before running this
+8 ;;option for all flag assignment fields except for the OWNER SITE
+9 ;;field.
+10 ;;
+11 ;;If you are running this option because a previous CHANGE OF
+12 ;;OWNERSHIP action failed to properly update all facilities, then this
+13 ;;option will prompt you for the name of that facility which is to be
+14 ;;the OWNER SITE for this flag assignment.
+15 ;;[end]
26 ;;Record flag assignment currently in use, cannot be edited!
+1 ;;[end]
28 ;;Unable to retrieve the record flag assignment selected.
+1 ;;[end]
30 ;;Enter the reason for exercising this option.
+1 ;;Enter 'O' if a change of ownership was done but some HL7 update
+2 ;; message failed resulting if various facilities having a different
+3 ;; value for the OWNER SITE field for this assignment.
+4 ;;Enter 'U' for all other reasons.
+5 ;;[end]
36 ;;Your TREATING FACILITY LIST file does not show any other VAMC
+1 ;;facilities as having registered this patient. Please use one of the
+2 ;;other Patient Record Flag options to correct the data for this flag
+3 ;;assignment.
+4 ;;[end]
41 ;;You have selected this Facility/Division as the OWNER SITE:
+1 ;;
+2 ;;This assignment will now be refreshed/resent to all sites where
+3 ;;this patient has been registered.
+4 ;;[end]
46 ;;PRF Assignment update for change of ownership failed.
+1 ;;No HL7 update messages were sent to the other sites.
+2 ;;Creating a PRF Assignment History record of this action.
+3 ;;PRF Assignment History record was not filed successfully.
+4 ;;HL7 message sent...updating patient's sites of record.
+5 ;;HL7 message **NOT** sent updating patient's sites of record.
+6 ;;[end]
