DGPFTR1 ;SHRPE/YMG - PRF TRANSFER REQUESTS ACTIONS ; 05/08/18
;;5.3;Registration;**951**;Aug 13, 1993;Build 135
;;Per VA Directive 6402, this routine should not be modified.
;
; List Manager actions for DGPF PRF TRANSFER REQUESTS option.
;
Q
;
CV ; change list view
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
N DTMOK,EDTM,FLAG,PAT,QID,SDTM,STATUS,STR,TMPDTM,XQY0
D FULL^VALM1,CLEAR^VALM1
S STR=""
; query Id selection
S QID=$$ASKALL("query Id","query Ids") I QID="" G CVX
I QID'="ALL" S QID=$$SELQID() S STR=QID D BLDHDR^DGPFTR(STR),BLD^DGPFTR(STR) G CVX
; patient selection
S PAT=$$ASKALL("patient","patients") I PAT="" G CVX
I PAT'="ALL" D I $D(DUOUT)!$D(DTOUT) G CVX
.S DIR(0)="PA^2:AEMQ"
.S DIR("S")="I $O(^DGPF(26.22,""D"",Y,""""))"
.S DIR("A",1)=""
.S DIR("A")="Select patient to view requests for: "
.D ^DIR K DIR
.S PAT=$P(Y,U) ; patient DFN
.Q
; flag selection
S FLAG=$$ASKALL("flag","flags") I FLAG="" G CVX
I FLAG'="ALL" D I $D(DUOUT)!$D(DTOUT) G CVX
.S DIR(0)="PA^26.15:AEMQ"
.S DIR("A",1)=""
.S DIR("A")="Select record flag to view requests for: "
.D ^DIR K DIR
.S FLAG=$P(Y,U) ; flag ien in file 26.15
.Q
; status selection
S STATUS=$$ASKALL("status","statuses") I STATUS="" G CVX
I STATUS'="ALL" D I $D(DUOUT)!$D(DTOUT) G CVX
.S DIR(0)="26.22,.05A"
.S DIR("A",1)=""
.S DIR("A")="Select status of the requests to view: "
.D ^DIR K DA,DIR
.S STATUS=+Y ; internal status code (26.22/.05)
.Q
; date/time selection
S SDTM=$$ASKALL("date/time","dates/times") I SDTM="" G CVX
I SDTM'="ALL" D I $D(DUOUT)!$D(DTOUT) G CVX
.S TMPDTM=$O(^DGPF(26.22,"B",""))
.S DIR(0)="DA^::TSX"
.S DIR("A",1)=""
.S DIR("A",2)="Note: starting date defaults to the earliest request on file."
.S DIR("A",3)=""
.S DIR("A")="Enter the starting date of the requests to view: "
.S DIR("B")=$$FMTE^XLFDT(TMPDTM,1)
.D ^DIR K DIR
.S SDTM=+Y
.I $D(DUOUT)!$D(DTOUT) Q
.S TMPDTM=$O(^DGPF(26.22,"B",""),-1)
.S DTMOK=0 F D Q:DTMOK!$D(DUOUT)!$D(DTOUT)
..S DIR(0)="DA^::TSX"
..S DIR("A",1)=""
..S DIR("A",2)="Note: ending date defaults to the latest request on file."
..S DIR("A",3)=""
..S DIR("A")="Enter the ending date of the requests to view: "
..S DIR("B")=$$FMTE^XLFDT(TMPDTM,1)
..D ^DIR K DIR I $D(DUOUT)!$D(DTOUT) Q
..I SDTM>+Y W !!!,"Starting date cannot be later than ending date!",! Q
..S DTMOK=1
..Q
.S EDTM=+Y
.Q
S STR=QID_U_PAT_U_FLAG_U_STATUS_U_SDTM S:$G(EDTM) STR=STR_U_EDTM
S VALMBG=1 D BLDHDR^DGPFTR(STR),BLD^DGPFTR(STR)
S DSPSTR=STR ; save new display filters
;
CVX ; exit point
S VALMBCK="R"
Q
;
SELQID() ; user prompt for selection of query Id
;
; returns selected query Id or "" for user exit
;
N D,DIC,DTOUT,DUOUT,X,Y
S DIC="^DGPF(26.22,",DIC(0)="AEOQSX",D="C"
S DIC("A")="Select query Id of the request to view: "
D IX^DIC
I $D(DUOUT)!$D(DTOUT) Q ""
Q X
;
ASKALL(STR1,STR2) ; user prompt for All / Selected
; STR1 - item name to ask about (singular)
; STR2 - item name to ask about (plural)
;
; returns "ALL" for All, "S" for singular, or "" for user exit
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR("B")="ALL"
S DIR("A",1)=""
S DIR("A")="View requests for all "_STR2_" or selected "_STR1_" (ALL/S): "
S DIR(0)="SA^ALL:All "_STR2_";S:Selected "_STR1
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) Q ""
Q Y
;
SD ; show request details
N DGFDA,DGIEN,IENS,SEL
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)),"S")
S SEL=$O(VALMY("")) I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D
.S DGIEN=+$G(@VALMAR@("IDX",SEL,SEL)) I 'DGIEN W !!,"Invalid selection." Q
.S IENS=DGIEN_"," D GETS^DIQ(26.22,IENS,"*","E","DGFDA")
.W !!," Transfer request details:"
.W !," -------------------------"
.D DISPREQ(IENS,.DGFDA)
.Q
D PAUSE^VALM1
S VALMBCK="R"
Q
;
RR ; review pending request
N ACT,ASGIEN,DATAARY,DFN,DGERR,DGFDA,DGFERR,DGICN,DGIEN,DGPFA,IENS,SEL,STATUS
D FULL^VALM1
D EN^VALM2($G(XQORNOD(0)),"S")
S SEL=$O(VALMY("")) I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D
.S DGIEN=+$G(@VALMAR@("IDX",SEL,SEL)) I 'DGIEN W !!,"Invalid selection." Q
.S IENS=DGIEN_"," D GETS^DIQ(26.22,IENS,"*","EI","DGFDA")
.S STATUS=$G(DGFDA(26.22,IENS,.05,"I"))
.; if request status is not "PENDING", bail out
.I STATUS'=2 D Q
..W !!,"Only transfer requests with 'PENDING' status are eligible for review."
..W !,"This request has ",$G(DGFDA(26.22,IENS,.05,"E"))," status!"
..Q
.W !!," Review transfer request:"
.W !," ------------------------"
.D DISPREQ(IENS,.DGFDA)
.S ACT=$$ASKREV() ; ask user for approval / rejection
.I ACT'="" D
..S DATAARY("REVCMT")=$$ASKRSN(1,$S(ACT="R":1,1:0)) I ACT="R",DATAARY("REVCMT")="" Q
..S DGERR=""
..S DATAARY("REQDTM")=$G(DGFDA(26.22,IENS,.01,"I"))
..S DFN=$G(DGFDA(26.22,IENS,.03,"I"))
..I '$$MPIOK^DGPFUT(DFN,.DGICN) W !!,"Invalid patient ICN - must be national." Q
..S DATAARY("DFN")=DFN
..S DATAARY("ICN")=DGICN
..S DATAARY("FLAG")=$G(DGFDA(26.22,IENS,.04,"I"))
..S DATAARY("REVBY")=$$GET1^DIQ(200,DUZ_",",.01)
..S DATAARY("REVDTM")=$$NOW^XLFDT()
..S DATAARY("REQID")=$G(DGFDA(26.22,IENS,.08,"E"))
..S DATAARY("MSGID")=$G(DGFDA(26.22,IENS,.09,"E"))
..S DATAARY("QOK")=1
..S DATAARY("REVRES")=$S(ACT="R":"D",1:"A")
..; update log entry
..L +^DGPF(26.22,DGIEN):5 I '$T W !!,"Record locked by another user. Please try again later." Q
..D UPDLOG^DGPFHLT3(IENS,"",.DATAARY,.DGFERR)
..L -^DGPF(26.22,DGIEN)
..I $D(DGFERR) D Q
...W !!,"Error while updating log entry with ien = ",DGIEN
...W !,"Error code: ",$G(DGFERR("DIERR",1))
...W !,"Error text: ",$G(DGFERR("DIERR",1,"TEXT",1))
...Q
..S DATAARY("REVDUZ")=DUZ
..S DATAARY("SENDTO")=$P($$PARENT^DGPFUT1($G(DGFDA(26.22,IENS,.1,"I"))),U)
..I DATAARY("SENDTO")=0 S DATAARY("SENDTO")=$G(DGFDA(26.22,IENS,.1,"I"))
..S ASGIEN=$$FNDASGN^DGPFAA(DFN,DATAARY("FLAG")_";DGPF(26.15,") ; PRF assignment ien in file 26.13
..I ASGIEN'>0 S DGERR="Receiver was unable to find corresponding PRF flag assignment."
..I DGERR="",'$$GETASGN^DGPFAA(ASGIEN,.DGPFA,1) S DGERR="Receiver was unable to retrieve corresponding PRF flag assignment."
..S DATAARY("ORIGOWN")=$P($G(DGPFA("OWNER")),U)
..S DATAARY("SFIEN")=$S(ACT="R":$P($G(DGPFA("OWNER")),U),1:$G(DGFDA(26.22,IENS,.1,"I")))
..S DATAARY("SFNAME")="Station # "_$$STA^XUAF4(DATAARY("SFIEN"))_"("_$$NAME^XUAF4(DATAARY("SFIEN"))_")"
..I ACT="A" D
...; approved request - change ownership
...I DGERR="" S DGERR=$$UPDASGN^DGPFHLT1(0,ASGIEN,.DATAARY,.DGPFA)
...Q
..; send response message (RSP^K11)
..D SEND^DGPFHLT2(DGERR,.DATAARY)
..D BLD^DGPFTR(DSPSTR) ; rebuild display list
..Q
.Q
D PAUSE^VALM1
S VALMBCK="R"
Q
;
DISPREQ(IENS,DGFDA) ; display request data
; IENS - ien in file 26.22_","
; DGFDA - FDA array containing data for a given transfer request log entry
;
N STR
I '$D(DGFDA) Q
W !
S STR=$G(DGFDA(26.22,IENS,.01,"E"))
W !,"Request date/time: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.02,"E"))
W !,"Requester name: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,2.01,"E"))
W !,"Request reason: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.03,"E"))
W !,"Patient name: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.04,"E"))
W !,"Record flag name: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.05,"E"))
W !,"Request status: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.06,"E"))
W !,"Reviewer name: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.07,"E"))
W !,"Review date/time: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,2.02,"E"))
W !,"Review reason: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.08,"E"))
W !,"Query id: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.09,"E"))
W !,"HL7 message id: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,.1,"E"))
W !,"Requesting facility: ",$S(STR'="":STR,1:"N/A")
S STR=$G(DGFDA(26.22,IENS,1,"E"))
W !,"Error message: ",$S(STR'="":STR,1:"N/A")
Q
;
ASKREV() ; user prompt for request approval / rejection
;
; returns "A" for Approval, "R" for rejection, or "" for user exit
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR("A",1)=""
S DIR("A",2)=""
S DIR("A")="Do you wish to approve or reject this transfer request? (A/R): "
S DIR(0)="SA^A:Approve request;R:Reject request"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) Q ""
Q Y
;
ASKRSN(TYPE,RFLG) ; user prompt for request / response reason
;
; TYPE = 0 for request reason, 1 for response reason
; RFLG = 0 for optional entry, 1 for required entry
;
; returns entered reason or "" for user exit
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR("A",1)=""
S DIR("A",2)=""
S DIR("A")="Ownership Request"_$S(TYPE:" Approval/Rejection",1:"")_" Reason: "
S DIR(0)="FA"_$S(RFLG:"",1:"O")_"^10:80"
D ^DIR K DIR
I $D(DUOUT)!$D(DTOUT) Q ""
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPFTR1 8981 printed Dec 13, 2024@02:48:48 Page 2
DGPFTR1 ;SHRPE/YMG - PRF TRANSFER REQUESTS ACTIONS ; 05/08/18
+1 ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; List Manager actions for DGPF PRF TRANSFER REQUESTS option.
+5 ;
+6 QUIT
+7 ;
CV ; change list view
+1 NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 NEW DTMOK,EDTM,FLAG,PAT,QID,SDTM,STATUS,STR,TMPDTM,XQY0
+3 DO FULL^VALM1
DO CLEAR^VALM1
+4 SET STR=""
+5 ; query Id selection
+6 SET QID=$$ASKALL("query Id","query Ids")
IF QID=""
GOTO CVX
+7 IF QID'="ALL"
SET QID=$$SELQID()
SET STR=QID
DO BLDHDR^DGPFTR(STR)
DO BLD^DGPFTR(STR)
GOTO CVX
+8 ; patient selection
+9 SET PAT=$$ASKALL("patient","patients")
IF PAT=""
GOTO CVX
+10 IF PAT'="ALL"
Begin DoDot:1
+11 SET DIR(0)="PA^2:AEMQ"
+12 SET DIR("S")="I $O(^DGPF(26.22,""D"",Y,""""))"
+13 SET DIR("A",1)=""
+14 SET DIR("A")="Select patient to view requests for: "
+15 DO ^DIR
KILL DIR
+16 ; patient DFN
SET PAT=$PIECE(Y,U)
+17 QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CVX
+18 ; flag selection
+19 SET FLAG=$$ASKALL("flag","flags")
IF FLAG=""
GOTO CVX
+20 IF FLAG'="ALL"
Begin DoDot:1
+21 SET DIR(0)="PA^26.15:AEMQ"
+22 SET DIR("A",1)=""
+23 SET DIR("A")="Select record flag to view requests for: "
+24 DO ^DIR
KILL DIR
+25 ; flag ien in file 26.15
SET FLAG=$PIECE(Y,U)
+26 QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CVX
+27 ; status selection
+28 SET STATUS=$$ASKALL("status","statuses")
IF STATUS=""
GOTO CVX
+29 IF STATUS'="ALL"
Begin DoDot:1
+30 SET DIR(0)="26.22,.05A"
+31 SET DIR("A",1)=""
+32 SET DIR("A")="Select status of the requests to view: "
+33 DO ^DIR
KILL DA,DIR
+34 ; internal status code (26.22/.05)
SET STATUS=+Y
+35 QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CVX
+36 ; date/time selection
+37 SET SDTM=$$ASKALL("date/time","dates/times")
IF SDTM=""
GOTO CVX
+38 IF SDTM'="ALL"
Begin DoDot:1
+39 SET TMPDTM=$ORDER(^DGPF(26.22,"B",""))
+40 SET DIR(0)="DA^::TSX"
+41 SET DIR("A",1)=""
+42 SET DIR("A",2)="Note: starting date defaults to the earliest request on file."
+43 SET DIR("A",3)=""
+44 SET DIR("A")="Enter the starting date of the requests to view: "
+45 SET DIR("B")=$$FMTE^XLFDT(TMPDTM,1)
+46 DO ^DIR
KILL DIR
+47 SET SDTM=+Y
+48 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+49 SET TMPDTM=$ORDER(^DGPF(26.22,"B",""),-1)
+50 SET DTMOK=0
FOR
Begin DoDot:2
+51 SET DIR(0)="DA^::TSX"
+52 SET DIR("A",1)=""
+53 SET DIR("A",2)="Note: ending date defaults to the latest request on file."
+54 SET DIR("A",3)=""
+55 SET DIR("A")="Enter the ending date of the requests to view: "
+56 SET DIR("B")=$$FMTE^XLFDT(TMPDTM,1)
+57 DO ^DIR
KILL DIR
IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+58 IF SDTM>+Y
WRITE !!!,"Starting date cannot be later than ending date!",!
QUIT
+59 SET DTMOK=1
+60 QUIT
End DoDot:2
if DTMOK!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
+61 SET EDTM=+Y
+62 QUIT
End DoDot:1
IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO CVX
+63 SET STR=QID_U_PAT_U_FLAG_U_STATUS_U_SDTM
if $GET(EDTM)
SET STR=STR_U_EDTM
+64 SET VALMBG=1
DO BLDHDR^DGPFTR(STR)
DO BLD^DGPFTR(STR)
+65 ; save new display filters
SET DSPSTR=STR
+66 ;
CVX ; exit point
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
SELQID() ; user prompt for selection of query Id
+1 ;
+2 ; returns selected query Id or "" for user exit
+3 ;
+4 NEW D,DIC,DTOUT,DUOUT,X,Y
+5 SET DIC="^DGPF(26.22,"
SET DIC(0)="AEOQSX"
SET D="C"
+6 SET DIC("A")="Select query Id of the request to view: "
+7 DO IX^DIC
+8 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT ""
+9 QUIT X
+10 ;
ASKALL(STR1,STR2) ; user prompt for All / Selected
+1 ; STR1 - item name to ask about (singular)
+2 ; STR2 - item name to ask about (plural)
+3 ;
+4 ; returns "ALL" for All, "S" for singular, or "" for user exit
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 SET DIR("B")="ALL"
+8 SET DIR("A",1)=""
+9 SET DIR("A")="View requests for all "_STR2_" or selected "_STR1_" (ALL/S): "
+10 SET DIR(0)="SA^ALL:All "_STR2_";S:Selected "_STR1
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT ""
+13 QUIT Y
+14 ;
SD ; show request details
+1 NEW DGFDA,DGIEN,IENS,SEL
+2 DO FULL^VALM1
+3 DO EN^VALM2($GET(XQORNOD(0)),"S")
+4 SET SEL=$ORDER(VALMY(""))
IF SEL
IF $DATA(@VALMAR@("IDX",SEL,SEL))
Begin DoDot:1
+5 SET DGIEN=+$GET(@VALMAR@("IDX",SEL,SEL))
IF 'DGIEN
WRITE !!,"Invalid selection."
QUIT
+6 SET IENS=DGIEN_","
DO GETS^DIQ(26.22,IENS,"*","E","DGFDA")
+7 WRITE !!," Transfer request details:"
+8 WRITE !," -------------------------"
+9 DO DISPREQ(IENS,.DGFDA)
+10 QUIT
End DoDot:1
+11 DO PAUSE^VALM1
+12 SET VALMBCK="R"
+13 QUIT
+14 ;
RR ; review pending request
+1 NEW ACT,ASGIEN,DATAARY,DFN,DGERR,DGFDA,DGFERR,DGICN,DGIEN,DGPFA,IENS,SEL,STATUS
+2 DO FULL^VALM1
+3 DO EN^VALM2($GET(XQORNOD(0)),"S")
+4 SET SEL=$ORDER(VALMY(""))
IF SEL
IF $DATA(@VALMAR@("IDX",SEL,SEL))
Begin DoDot:1
+5 SET DGIEN=+$GET(@VALMAR@("IDX",SEL,SEL))
IF 'DGIEN
WRITE !!,"Invalid selection."
QUIT
+6 SET IENS=DGIEN_","
DO GETS^DIQ(26.22,IENS,"*","EI","DGFDA")
+7 SET STATUS=$GET(DGFDA(26.22,IENS,.05,"I"))
+8 ; if request status is not "PENDING", bail out
+9 IF STATUS'=2
Begin DoDot:2
+10 WRITE !!,"Only transfer requests with 'PENDING' status are eligible for review."
+11 WRITE !,"This request has ",$GET(DGFDA(26.22,IENS,.05,"E"))," status!"
+12 QUIT
End DoDot:2
QUIT
+13 WRITE !!," Review transfer request:"
+14 WRITE !," ------------------------"
+15 DO DISPREQ(IENS,.DGFDA)
+16 ; ask user for approval / rejection
SET ACT=$$ASKREV()
+17 IF ACT'=""
Begin DoDot:2
+18 SET DATAARY("REVCMT")=$$ASKRSN(1,$SELECT(ACT="R":1,1:0))
IF ACT="R"
IF DATAARY("REVCMT")=""
QUIT
+19 SET DGERR=""
+20 SET DATAARY("REQDTM")=$GET(DGFDA(26.22,IENS,.01,"I"))
+21 SET DFN=$GET(DGFDA(26.22,IENS,.03,"I"))
+22 IF '$$MPIOK^DGPFUT(DFN,.DGICN)
WRITE !!,"Invalid patient ICN - must be national."
QUIT
+23 SET DATAARY("DFN")=DFN
+24 SET DATAARY("ICN")=DGICN
+25 SET DATAARY("FLAG")=$GET(DGFDA(26.22,IENS,.04,"I"))
+26 SET DATAARY("REVBY")=$$GET1^DIQ(200,DUZ_",",.01)
+27 SET DATAARY("REVDTM")=$$NOW^XLFDT()
+28 SET DATAARY("REQID")=$GET(DGFDA(26.22,IENS,.08,"E"))
+29 SET DATAARY("MSGID")=$GET(DGFDA(26.22,IENS,.09,"E"))
+30 SET DATAARY("QOK")=1
+31 SET DATAARY("REVRES")=$SELECT(ACT="R":"D",1:"A")
+32 ; update log entry
+33 LOCK +^DGPF(26.22,DGIEN):5
IF '$TEST
WRITE !!,"Record locked by another user. Please try again later."
QUIT
+34 DO UPDLOG^DGPFHLT3(IENS,"",.DATAARY,.DGFERR)
+35 LOCK -^DGPF(26.22,DGIEN)
+36 IF $DATA(DGFERR)
Begin DoDot:3
+37 WRITE !!,"Error while updating log entry with ien = ",DGIEN
+38 WRITE !,"Error code: ",$GET(DGFERR("DIERR",1))
+39 WRITE !,"Error text: ",$GET(DGFERR("DIERR",1,"TEXT",1))
+40 QUIT
End DoDot:3
QUIT
+41 SET DATAARY("REVDUZ")=DUZ
+42 SET DATAARY("SENDTO")=$PIECE($$PARENT^DGPFUT1($GET(DGFDA(26.22,IENS,.1,"I"))),U)
+43 IF DATAARY("SENDTO")=0
SET DATAARY("SENDTO")=$GET(DGFDA(26.22,IENS,.1,"I"))
+44 ; PRF assignment ien in file 26.13
SET ASGIEN=$$FNDASGN^DGPFAA(DFN,DATAARY("FLAG")_";DGPF(26.15,")
+45 IF ASGIEN'>0
SET DGERR="Receiver was unable to find corresponding PRF flag assignment."
+46 IF DGERR=""
IF '$$GETASGN^DGPFAA(ASGIEN,.DGPFA,1)
SET DGERR="Receiver was unable to retrieve corresponding PRF flag assignment."
+47 SET DATAARY("ORIGOWN")=$PIECE($GET(DGPFA("OWNER")),U)
+48 SET DATAARY("SFIEN")=$SELECT(ACT="R":$PIECE($GET(DGPFA("OWNER")),U),1:$GET(DGFDA(26.22,IENS,.1,"I")))
+49 SET DATAARY("SFNAME")="Station # "_$$STA^XUAF4(DATAARY("SFIEN"))_"("_$$NAME^XUAF4(DATAARY("SFIEN"))_")"
+50 IF ACT="A"
Begin DoDot:3
+51 ; approved request - change ownership
+52 IF DGERR=""
SET DGERR=$$UPDASGN^DGPFHLT1(0,ASGIEN,.DATAARY,.DGPFA)
+53 QUIT
End DoDot:3
+54 ; send response message (RSP^K11)
+55 DO SEND^DGPFHLT2(DGERR,.DATAARY)
+56 ; rebuild display list
DO BLD^DGPFTR(DSPSTR)
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
+59 DO PAUSE^VALM1
+60 SET VALMBCK="R"
+61 QUIT
+62 ;
DISPREQ(IENS,DGFDA) ; display request data
+1 ; IENS - ien in file 26.22_","
+2 ; DGFDA - FDA array containing data for a given transfer request log entry
+3 ;
+4 NEW STR
+5 IF '$DATA(DGFDA)
QUIT
+6 WRITE !
+7 SET STR=$GET(DGFDA(26.22,IENS,.01,"E"))
+8 WRITE !,"Request date/time: ",$SELECT(STR'="":STR,1:"N/A")
+9 SET STR=$GET(DGFDA(26.22,IENS,.02,"E"))
+10 WRITE !,"Requester name: ",$SELECT(STR'="":STR,1:"N/A")
+11 SET STR=$GET(DGFDA(26.22,IENS,2.01,"E"))
+12 WRITE !,"Request reason: ",$SELECT(STR'="":STR,1:"N/A")
+13 SET STR=$GET(DGFDA(26.22,IENS,.03,"E"))
+14 WRITE !,"Patient name: ",$SELECT(STR'="":STR,1:"N/A")
+15 SET STR=$GET(DGFDA(26.22,IENS,.04,"E"))
+16 WRITE !,"Record flag name: ",$SELECT(STR'="":STR,1:"N/A")
+17 SET STR=$GET(DGFDA(26.22,IENS,.05,"E"))
+18 WRITE !,"Request status: ",$SELECT(STR'="":STR,1:"N/A")
+19 SET STR=$GET(DGFDA(26.22,IENS,.06,"E"))
+20 WRITE !,"Reviewer name: ",$SELECT(STR'="":STR,1:"N/A")
+21 SET STR=$GET(DGFDA(26.22,IENS,.07,"E"))
+22 WRITE !,"Review date/time: ",$SELECT(STR'="":STR,1:"N/A")
+23 SET STR=$GET(DGFDA(26.22,IENS,2.02,"E"))
+24 WRITE !,"Review reason: ",$SELECT(STR'="":STR,1:"N/A")
+25 SET STR=$GET(DGFDA(26.22,IENS,.08,"E"))
+26 WRITE !,"Query id: ",$SELECT(STR'="":STR,1:"N/A")
+27 SET STR=$GET(DGFDA(26.22,IENS,.09,"E"))
+28 WRITE !,"HL7 message id: ",$SELECT(STR'="":STR,1:"N/A")
+29 SET STR=$GET(DGFDA(26.22,IENS,.1,"E"))
+30 WRITE !,"Requesting facility: ",$SELECT(STR'="":STR,1:"N/A")
+31 SET STR=$GET(DGFDA(26.22,IENS,1,"E"))
+32 WRITE !,"Error message: ",$SELECT(STR'="":STR,1:"N/A")
+33 QUIT
+34 ;
ASKREV() ; user prompt for request approval / rejection
+1 ;
+2 ; returns "A" for Approval, "R" for rejection, or "" for user exit
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 SET DIR("A",1)=""
+6 SET DIR("A",2)=""
+7 SET DIR("A")="Do you wish to approve or reject this transfer request? (A/R): "
+8 SET DIR(0)="SA^A:Approve request;R:Reject request"
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT ""
+11 QUIT Y
+12 ;
ASKRSN(TYPE,RFLG) ; user prompt for request / response reason
+1 ;
+2 ; TYPE = 0 for request reason, 1 for response reason
+3 ; RFLG = 0 for optional entry, 1 for required entry
+4 ;
+5 ; returns entered reason or "" for user exit
+6 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+7 SET DIR("A",1)=""
+8 SET DIR("A",2)=""
+9 SET DIR("A")="Ownership Request"_$SELECT(TYPE:" Approval/Rejection",1:"")_" Reason: "
+10 SET DIR(0)="FA"_$SELECT(RFLG:"",1:"O")_"^10:80"
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT ""
+13 QUIT Y
