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

DGPFLMA5.m

Go to the documentation of this file. 
  1. DGPFLMA5 ;SLC/SS - PRF ASSIGNMENT LM PROTOCOL ACTIONS CONT. ; 01/24/18
  1.  ;;5.3;Registration;**951**;Aug 13, 1993;Build 135
  1.  ;
  1.  ;no direct entry
  1.  Q
  1.  ;
  1. TR ; Entry point for DGPF TRANSFER FLAG action protocol.
  1.  N DGDFN     ; Pointer to patient in PATIENT (#2) file
  1.  N DGIEN     ; Assignment ien
  1.  N DGPFA     ; Assignment array
  1.  N SEL       ; User selection (list item)
  1.  N REASON    ; reason for the request
  1.  N RES       ; Result of request attempt
  1.  N DIV       ; sign-on division name ^ sign-on division station #
  1.  N OWNER     ; current flag owner
  1.  N Z
  1.  ;
  1.  ; Set screen to full scroll region
  1.  D FULL^VALM1
  1.  S VALMBCK="R"
  1.  ; Quit if selected action is not appropriate
  1.  I '$D(@VALMAR@("IDX")) D DISPMSG("0^0^^Action not permitted - "_$S('$G(DGDFN):"Patient has not been selected.",1:"Patient has no record flag assignments.")) Q
  1.  ; Quit if user's DUZ(2) is not an enabled division for PRF ASSIGNMENT OWNERSHIP
  1.  I '$D(^DG(40.8,"APRF",+DUZ(2))) D DISPMSG("0^0^^Action not permitted - You are signed into a division which is not PRF enabled, the FT action cannot be used to request PRF transfer to this division") Q
  1.  ; Quit if user's DUZ(2) is neither parent facility, nor a division in an integrated site
  1.  I '$$CHKINT() D DISPMSG("0^0^^Action not permitted - You are signed into a division which is neither a parent facility, nor a VAMC type division in an integrated site.") Q
  1.  ; Allow user to select a single flag assignment
  1.  S DGIEN="" D EN^VALM2($G(XQORNOD(0)),"S")
  1.  ; Process user selection
  1.  S SEL=$O(VALMY("")) I 'SEL Q
  1.  S DGIEN=$P($G(@VALMAR@("IDX",SEL,SEL)),U)
  1.  S DGDFN=$P($G(@VALMAR@("IDX",SEL,SEL)),U,2)
  1.  S DIV=$$NS^XUAF4(+DUZ(2))
  1.  ; Attempt to obtain lock on assignment record
  1.  I '$$LOCK^DGPFAA3(DGIEN) D DISPMSG("0^0^^Record flag assignment currently in use.") Q
  1.  ; Get assignment into DGPFA array
  1.  I '$$GETASGN^DGPFAA(DGIEN,.DGPFA) D DISPMSG("0^0^^Unable to retrieve the record flag assignment selected.") G TRX
  1.  ; Check who is the current owner
  1.  S Z=$$PARENT^DGPFUT1($P($G(DGPFA("OWNER")),U))
  1.  S OWNER=$P(Z,U) I OWNER=0!($P(Z,U,3)="") S OWNER=$P($G(DGPFA("OWNER")),U)
  1.  I OWNER=+DUZ(2)!(OWNER=$P($$PARENT^DGPFUT1(+DUZ(2)),U)) D DISPMSG("0^0^^Your division/facility is the current owner of this record flag assignment.") G TRX
  1.  ;
  1.  I DGPFA("FLAG")'["26.15" D DISPMSG("0^0^^Only ownership of national (Cat I) flag assignments can be transferred.") G TRX
  1.  ; prompt for request reason
  1.  S REASON=$$ASKRSN^DGPFTR1(0,1) I REASON="" G TRX
  1.  ;
  1.  W !!,"You're about to request ownership transfer of the following"
  1.  W !,"record flag assignment to division "_$P(DIV,U)_" (station #"_$P(DIV,U,2)_"):"
  1.  W !!,"Patient:         ",$P($G(DGPFA("DFN")),U,2)
  1.  W !,"PRF flag:        ",$P($G(DGPFA("FLAG")),U,2)
  1.  W !,"PRF flag status: ",$P($G(DGPFA("STATUS")),U,2)
  1.  W !,"Current owner:   ",$P($G(DGPFA("OWNER")),U,2)
  1.  W !,"Request reason:  ",REASON
  1.  I '$$ASKCONT() G TRX
  1.  ;
  1.  S RES=$$SEND^DGPFHLT(DGDFN,$P($P($G(DGPFA("FLAG")),U),";"),OWNER,REASON)
  1.  ;
  1.  D DISPMSG(RES)
  1.  ; rebuild list of flag assignments for this patient
  1.  D BLDLIST^DGPFLMU(DGDFN)
  1. TRX ; exit point
  1.  ; Release lock on assignment record
  1.  D UNLOCK^DGPFAA3(DGIEN)
  1.  Q
  1.  ;
  1. ASKCONT() ; Asks user if they wish to continue
  1.  ; Returns 1 if response is "YES", 0 otherwise
  1.  ;
  1.  N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="Y",DIR("A")="Do you wish to send this request",DIR("B")="NO"
  1.  D ^DIR
  1.  Q +Y
  1.  ;
  1. DISPMSG(MSG) ; Display message to the user
  1.  ; status^HL7 message id^error code^error description^error source
  1.  N ERRSTR,HL7OK,Z
  1.  S ERRSTR="the following error has occurred:"
  1.  S HL7OK="Transfer request sent successfully."
  1.  I +MSG W !!,HL7OK
  1.  I '+MSG D
  1.  .I +$P(MSG,U,5)=0 W !!,"Unable to proceed, ",ERRSTR
  1.  .I +$P(MSG,U,5)=1 W !!,"Unable to send transfer request, ",ERRSTR
  1.  .I +$P(MSG,U,5)=2 W !!,HL7OK,!,"...but error occurred while filing log entry:"
  1.  .W !
  1.  .S Z=$P(MSG,U,2) I +Z W !?2,"HL7 Message ID: ",Z
  1.  .S Z=$P(MSG,U,3) I +Z W !?2,"Error Code: ",Z
  1.  .S Z=$P(MSG,U,4) I Z'="" W !?2,"Error Text: ",!,Z
  1.  .Q
  1.  D PAUSE^VALM1
  1.  Q
  1.  ;
  1. CHKINT() ; check for integrated site divisions
  1.  ; only ingrated site divisions are allowed to use FT action
  1.  ;
  1.  ; returns 1 if division is allowed to use FT, 0 otherwise
  1.  ;
  1.  N DIV,DIVST,EXCLUDE,FDATA,INTFCLTY,PARENT,PRNTIEN,PRNTST,RES
  1.  ;
  1.  S INTFCLTY="^528^589^636^657^" ; list of int. site parent facilities (station #s)
  1.  S EXCLUDE="^636A4^636A5^" ; list of divisions excluded from transfers (special case for VISN 23)
  1.  S DIV=+DUZ(2) ; sign-on division ien
  1.  S RES=0
  1.  S PARENT=$$PARENT^DGPFUT1(DIV),DIVST=$$STA^XUAF4(DIV),PRNTIEN=$P(PARENT,U),PRNTST=$P(PARENT,U,3)
  1.  I PRNTIEN=0!(PRNTST="")!(PRNTIEN=DIV) S RES=1 ; it's a parent facility
  1.  I 'RES,EXCLUDE'[(U_DIVST_U) D
  1.  .; not on excluded divisions list
  1.  .I INTFCLTY[(U_PRNTST_U) D
  1.  ..; division's parent is on integrated facility list
  1.  ..D F4^XUAF4(DIVST,.FDATA)
  1.  ..I $G(FDATA("TYPE"))="VAMC" S RES=1 ; division's facility type is VAMC
  1.  ..Q
  1.  .Q
  1.  Q RES