Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPFTR1

DGPFTR1.m

Go to the documentation of this file. 
  1. DGPFTR1 ;SHRPE/YMG - PRF TRANSFER REQUESTS ACTIONS ; 05/08/18
  1.  ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ; List Manager actions for DGPF PRF TRANSFER REQUESTS option.
  1.  ;
  1.  Q
  1.  ;
  1. CV ; change list view
  1.  N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  N DTMOK,EDTM,FLAG,PAT,QID,SDTM,STATUS,STR,TMPDTM,XQY0
  1.  D FULL^VALM1,CLEAR^VALM1
  1.  S STR=""
  1.  ; query Id selection
  1.  S QID=$$ASKALL("query Id","query Ids") I QID="" G CVX
  1.  I QID'="ALL" S QID=$$SELQID() S STR=QID D BLDHDR^DGPFTR(STR),BLD^DGPFTR(STR) G CVX
  1.  ; patient selection
  1.  S PAT=$$ASKALL("patient","patients") I PAT="" G CVX
  1.  I PAT'="ALL" D  I $D(DUOUT)!$D(DTOUT) G CVX
  1.  .S DIR(0)="PA^2:AEMQ"
  1.  .S DIR("S")="I $O(^DGPF(26.22,""D"",Y,""""))"
  1.  .S DIR("A",1)=""
  1.  .S DIR("A")="Select patient to view requests for: "
  1.  .D ^DIR K DIR
  1.  .S PAT=$P(Y,U) ; patient DFN
  1.  .Q
  1.  ; flag selection
  1.  S FLAG=$$ASKALL("flag","flags") I FLAG="" G CVX
  1.  I FLAG'="ALL" D  I $D(DUOUT)!$D(DTOUT) G CVX
  1.  .S DIR(0)="PA^26.15:AEMQ"
  1.  .S DIR("A",1)=""
  1.  .S DIR("A")="Select record flag to view requests for: "
  1.  .D ^DIR K DIR
  1.  .S FLAG=$P(Y,U) ; flag ien in file 26.15
  1.  .Q
  1.  ; status selection
  1.  S STATUS=$$ASKALL("status","statuses") I STATUS="" G CVX
  1.  I STATUS'="ALL" D  I $D(DUOUT)!$D(DTOUT) G CVX
  1.  .S DIR(0)="26.22,.05A"
  1.  .S DIR("A",1)=""
  1.  .S DIR("A")="Select status of the requests to view: "
  1.  .D ^DIR K DA,DIR
  1.  .S STATUS=+Y ; internal status code (26.22/.05)
  1.  .Q
  1.  ; date/time selection
  1.  S SDTM=$$ASKALL("date/time","dates/times") I SDTM="" G CVX
  1.  I SDTM'="ALL" D  I $D(DUOUT)!$D(DTOUT) G CVX
  1.  .S TMPDTM=$O(^DGPF(26.22,"B",""))
  1.  .S DIR(0)="DA^::TSX"
  1.  .S DIR("A",1)=""
  1.  .S DIR("A",2)="Note: starting date defaults to the earliest request on file."
  1.  .S DIR("A",3)=""
  1.  .S DIR("A")="Enter the starting date of the requests to view: "
  1.  .S DIR("B")=$$FMTE^XLFDT(TMPDTM,1)
  1.  .D ^DIR K DIR
  1.  .S SDTM=+Y
  1.  .I $D(DUOUT)!$D(DTOUT) Q
  1.  .S TMPDTM=$O(^DGPF(26.22,"B",""),-1)
  1.  .S DTMOK=0 F  D  Q:DTMOK!$D(DUOUT)!$D(DTOUT)
  1.  ..S DIR(0)="DA^::TSX"
  1.  ..S DIR("A",1)=""
  1.  ..S DIR("A",2)="Note: ending date defaults to the latest request on file."
  1.  ..S DIR("A",3)=""
  1.  ..S DIR("A")="Enter the ending date of the requests to view: "
  1.  ..S DIR("B")=$$FMTE^XLFDT(TMPDTM,1)
  1.  ..D ^DIR K DIR I $D(DUOUT)!$D(DTOUT) Q
  1.  ..I SDTM>+Y W !!!,"Starting date cannot be later than ending date!",! Q
  1.  ..S DTMOK=1
  1.  ..Q
  1.  .S EDTM=+Y
  1.  .Q
  1.  S STR=QID_U_PAT_U_FLAG_U_STATUS_U_SDTM S:$G(EDTM) STR=STR_U_EDTM
  1.  S VALMBG=1 D BLDHDR^DGPFTR(STR),BLD^DGPFTR(STR)
  1.  S DSPSTR=STR ; save new display filters
  1.  ;
  1. CVX ; exit point
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. SELQID() ; user prompt for selection of query Id
  1.  ;
  1.  ; returns selected query Id or "" for user exit
  1.  ;
  1.  N D,DIC,DTOUT,DUOUT,X,Y
  1.  S DIC="^DGPF(26.22,",DIC(0)="AEOQSX",D="C"
  1.  S DIC("A")="Select query Id of the request to view: "
  1.  D IX^DIC
  1.  I $D(DUOUT)!$D(DTOUT) Q ""
  1.  Q X
  1.  ;
  1. ASKALL(STR1,STR2) ; user prompt for All / Selected
  1.  ; STR1 - item name to ask about (singular)
  1.  ; STR2 - item name to ask about (plural)
  1.  ;
  1.  ; returns "ALL" for All, "S" for singular, or "" for user exit
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR("B")="ALL"
  1.  S DIR("A",1)=""
  1.  S DIR("A")="View requests for all "_STR2_" or selected "_STR1_" (ALL/S): "
  1.  S DIR(0)="SA^ALL:All "_STR2_";S:Selected "_STR1
  1.  D ^DIR K DIR
  1.  I $D(DUOUT)!$D(DTOUT) Q ""
  1.  Q Y
  1.  ;
  1. SD ; show request details
  1.  N DGFDA,DGIEN,IENS,SEL
  1.  D FULL^VALM1
  1.  D EN^VALM2($G(XQORNOD(0)),"S")
  1.  S SEL=$O(VALMY("")) I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D
  1.  .S DGIEN=+$G(@VALMAR@("IDX",SEL,SEL)) I 'DGIEN W !!,"Invalid selection." Q
  1.  .S IENS=DGIEN_"," D GETS^DIQ(26.22,IENS,"*","E","DGFDA")
  1.  .W !!,"     Transfer request details:"
  1.  .W !,"     -------------------------"
  1.  .D DISPREQ(IENS,.DGFDA)
  1.  .Q
  1.  D PAUSE^VALM1
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. RR ; review pending request
  1.  N ACT,ASGIEN,DATAARY,DFN,DGERR,DGFDA,DGFERR,DGICN,DGIEN,DGPFA,IENS,SEL,STATUS
  1.  D FULL^VALM1
  1.  D EN^VALM2($G(XQORNOD(0)),"S")
  1.  S SEL=$O(VALMY("")) I SEL,$D(@VALMAR@("IDX",SEL,SEL)) D
  1.  .S DGIEN=+$G(@VALMAR@("IDX",SEL,SEL)) I 'DGIEN W !!,"Invalid selection." Q
  1.  .S IENS=DGIEN_"," D GETS^DIQ(26.22,IENS,"*","EI","DGFDA")
  1.  .S STATUS=$G(DGFDA(26.22,IENS,.05,"I"))
  1.  .; if request status is not "PENDING", bail out
  1.  .I STATUS'=2 D  Q
  1.  ..W !!,"Only transfer requests with 'PENDING' status are eligible for review."
  1.  ..W !,"This request has ",$G(DGFDA(26.22,IENS,.05,"E"))," status!"
  1.  ..Q
  1.  .W !!,"     Review transfer request:"
  1.  .W !,"     ------------------------"
  1.  .D DISPREQ(IENS,.DGFDA)
  1.  .S ACT=$$ASKREV() ; ask user for approval / rejection
  1.  .I ACT'="" D
  1.  ..S DATAARY("REVCMT")=$$ASKRSN(1,$S(ACT="R":1,1:0)) I ACT="R",DATAARY("REVCMT")="" Q
  1.  ..S DGERR=""
  1.  ..S DATAARY("REQDTM")=$G(DGFDA(26.22,IENS,.01,"I"))
  1.  ..S DFN=$G(DGFDA(26.22,IENS,.03,"I"))
  1.  ..I '$$MPIOK^DGPFUT(DFN,.DGICN) W !!,"Invalid patient ICN - must be national." Q
  1.  ..S DATAARY("DFN")=DFN
  1.  ..S DATAARY("ICN")=DGICN
  1.  ..S DATAARY("FLAG")=$G(DGFDA(26.22,IENS,.04,"I"))
  1.  ..S DATAARY("REVBY")=$$GET1^DIQ(200,DUZ_",",.01)
  1.  ..S DATAARY("REVDTM")=$$NOW^XLFDT()
  1.  ..S DATAARY("REQID")=$G(DGFDA(26.22,IENS,.08,"E"))
  1.  ..S DATAARY("MSGID")=$G(DGFDA(26.22,IENS,.09,"E"))
  1.  ..S DATAARY("QOK")=1
  1.  ..S DATAARY("REVRES")=$S(ACT="R":"D",1:"A")
  1.  ..; update log entry
  1.  ..L +^DGPF(26.22,DGIEN):5 I '$T W !!,"Record locked by another user. Please try again later." Q
  1.  ..D UPDLOG^DGPFHLT3(IENS,"",.DATAARY,.DGFERR)
  1.  ..L -^DGPF(26.22,DGIEN)
  1.  ..I $D(DGFERR) D  Q
  1.  ...W !!,"Error while updating log entry with ien = ",DGIEN
  1.  ...W !,"Error code: ",$G(DGFERR("DIERR",1))
  1.  ...W !,"Error text: ",$G(DGFERR("DIERR",1,"TEXT",1))
  1.  ...Q
  1.  ..S DATAARY("REVDUZ")=DUZ
  1.  ..S DATAARY("SENDTO")=$P($$PARENT^DGPFUT1($G(DGFDA(26.22,IENS,.1,"I"))),U)
  1.  ..I DATAARY("SENDTO")=0 S DATAARY("SENDTO")=$G(DGFDA(26.22,IENS,.1,"I"))
  1.  ..S ASGIEN=$$FNDASGN^DGPFAA(DFN,DATAARY("FLAG")_";DGPF(26.15,") ; PRF assignment ien in file 26.13
  1.  ..I ASGIEN'>0 S DGERR="Receiver was unable to find corresponding PRF flag assignment."
  1.  ..I DGERR="",'$$GETASGN^DGPFAA(ASGIEN,.DGPFA,1) S DGERR="Receiver was unable to retrieve corresponding PRF flag assignment."
  1.  ..S DATAARY("ORIGOWN")=$P($G(DGPFA("OWNER")),U)
  1.  ..S DATAARY("SFIEN")=$S(ACT="R":$P($G(DGPFA("OWNER")),U),1:$G(DGFDA(26.22,IENS,.1,"I")))
  1.  ..S DATAARY("SFNAME")="Station # "_$$STA^XUAF4(DATAARY("SFIEN"))_"("_$$NAME^XUAF4(DATAARY("SFIEN"))_")"
  1.  ..I ACT="A" D
  1.  ...; approved request - change ownership
  1.  ...I DGERR="" S DGERR=$$UPDASGN^DGPFHLT1(0,ASGIEN,.DATAARY,.DGPFA)
  1.  ...Q
  1.  ..; send response message (RSP^K11)
  1.  ..D SEND^DGPFHLT2(DGERR,.DATAARY)
  1.  ..D BLD^DGPFTR(DSPSTR) ; rebuild display list
  1.  ..Q
  1.  .Q
  1.  D PAUSE^VALM1
  1.  S VALMBCK="R"
  1.  Q
  1.  ;
  1. DISPREQ(IENS,DGFDA) ; display request data
  1.  ; IENS - ien in file 26.22_","
  1.  ; DGFDA - FDA array containing data for a given transfer request log entry
  1.  ;
  1.  N STR
  1.  I '$D(DGFDA) Q
  1.  W !
  1.  S STR=$G(DGFDA(26.22,IENS,.01,"E"))
  1.  W !,"Request date/time:   ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.02,"E"))
  1.  W !,"Requester name:      ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,2.01,"E"))
  1.  W !,"Request reason:      ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.03,"E"))
  1.  W !,"Patient name:        ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.04,"E"))
  1.  W !,"Record flag name:    ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.05,"E"))
  1.  W !,"Request status:      ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.06,"E"))
  1.  W !,"Reviewer name:       ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.07,"E"))
  1.  W !,"Review date/time:    ",$S(STR'="":STR,1:"N/A")
  1.   S STR=$G(DGFDA(26.22,IENS,2.02,"E"))
  1.  W !,"Review reason:       ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.08,"E"))
  1.  W !,"Query id:            ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.09,"E"))
  1.  W !,"HL7 message id:      ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,.1,"E"))
  1.  W !,"Requesting facility: ",$S(STR'="":STR,1:"N/A")
  1.  S STR=$G(DGFDA(26.22,IENS,1,"E"))
  1.  W !,"Error message:       ",$S(STR'="":STR,1:"N/A")
  1.  Q
  1.  ;
  1. ASKREV() ; user prompt for request approval / rejection
  1.  ;
  1.  ; returns "A" for Approval, "R" for rejection, or "" for user exit
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR("A",1)=""
  1.  S DIR("A",2)=""
  1.  S DIR("A")="Do you wish to approve or reject this transfer request? (A/R): "
  1.  S DIR(0)="SA^A:Approve request;R:Reject request"
  1.  D ^DIR K DIR
  1.  I $D(DUOUT)!$D(DTOUT) Q ""
  1.  Q Y
  1.  ;
  1. ASKRSN(TYPE,RFLG) ; user prompt for request / response reason
  1.  ;
  1.  ; TYPE = 0 for request reason, 1 for response reason
  1.  ; RFLG = 0 for optional entry, 1 for required entry
  1.  ;
  1.  ; returns entered reason or "" for user exit
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR("A",1)=""
  1.  S DIR("A",2)=""
  1.  S DIR("A")="Ownership Request"_$S(TYPE:" Approval/Rejection",1:"")_" Reason: "
  1.  S DIR(0)="FA"_$S(RFLG:"",1:"O")_"^10:80"
  1.  D ^DIR K DIR
  1.  I $D(DUOUT)!$D(DTOUT) Q ""
  1.  Q Y