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

FBSHAUT.m

Go to the documentation of this file. 
  1. FBSHAUT ;WCIOFO/SAB - ENTER/EDIT STATE HOME AUTHORIZATION ;5/19/2014
  1.  ;;3.5;FEE BASIS;**13,108,151**;JAN 30, 1995;Build 14
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. ADD ; Enter new authorization
  1.  ; Called from option FBSH ENTER AUTH
  1.  D SETUP
  1.  I 'FBPOP F  D  Q:'$G(DFN)
  1.  . ; select patient
  1.  . D PAT Q:'$G(DFN)
  1.  . ; show patient demographics
  1.  . S FBPROG(0)=FBPROG
  1.  . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
  1.  . D ^FBAADEM
  1.  . S FBPROG=FBPROG(0)
  1.  . ; get dates
  1.  . D BDATES
  1.  . ; get POV
  1.  . D POV
  1.  . I FBBEGDT]"",FBPOV D
  1.  . . ; add/edit authorization
  1.  . . S DA(1)=DFN,X=FBBEGDT
  1.  . . S DIC="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",DLAYGO=161
  1.  . . S DIC("P")=$P(^DD(161,1,0),U,2)
  1.  . . K DD,DO D FILE^DICN K DIC,DLAYGO
  1.  . . I Y'>0 W $C(7),!,"AUTH. NOT ADDED" Q
  1.  . . S (DA,FBAAADA)=+Y
  1.  . . ; stuff required fields and edit remaining fields
  1.  . . S DIE="^FBAAA("_DA(1)_",1,"
  1.  . . S DR=".02////^S X=FBENDDT;.03////^S X=FBPROG;.07////^S X=FBPOV;.095////^S X=4;100////^S X=DUZ;.04;.021"
  1.  . . D ^DIE K DIE
  1.  . . ; queue MRA
  1.  . . S FBX=$$QMRA(DFN,FBAAADA,"A")
  1.  . ;
  1.  . ; unlock patient
  1.  . L -^FBAAA(DFN,FBPROG)
  1.  D WRAPUP
  1.  Q
  1.  ;
  1. CHANGE ; Change existing authorization
  1.  ; Called from option FBSH CHANGE AUTH
  1.  D SETUP
  1.  I 'FBPOP F  D  Q:'$G(DFN)
  1.  . ; select patient
  1.  . D PAT Q:'$G(DFN)
  1.  . ; select existing authorization
  1.  . S FBPROG(0)=FBPROG
  1.  . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
  1.  . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
  1.  . I FTP'="" D
  1.  . . S (DA,FBAAADA)=FTP,DA(1)=DFN
  1.  . . I $P($G(FBDMRA),U) W $C(7),!,"AUTH IS AUSTIN DELETED. USE THE REINSTATE OPTION TO CHANGE IT." Q
  1.  . . ; save current data
  1.  . . S FBAOLD=$G(^FBAAA(DA(1),1,DA,0)),FBANEW=""
  1.  . . S FBBEGDT=$P(FBAOLD,U),FBENDDT=$P(FBAOLD,U,2)
  1.  . . ; display current data
  1.  . . W !!,"FROM DATE: ",$$FMTE^XLFDT(FBBEGDT)," (No Editing)"
  1.  . . ; edit TO DATE and check for conflicts
  1.  . . D TDATE Q:FBENDDT=""
  1.  . . ; update/edit fields
  1.  . . S DIE="^FBAAA("_DA(1)_",1,"
  1.  . . S DR=".02////^S X=FBENDDT;100////^S X=DUZ;S FBTYPE=FBPROG;.07;.04;.021"
  1.  . . D ^DIE K DIE
  1.  . . ; if TO DATE or PURPOSE OF VISIT changed then queue MRA
  1.  . . S FBANEW=$G(^FBAAA(DA(1),1,DA,0))
  1.  . . I $P(FBANEW,U,2)'=$P(FBAOLD,U,2)!($P(FBANEW,U,7)'=$P(FBAOLD,U,7)) D
  1.  . . . ; queue MRA
  1.  . . . S FBX=$$QMRA(DFN,FBAAADA,"C")
  1.  . ;
  1.  . ; unlock patient
  1.  . L -^FBAAA(DFN,FBPROG)
  1.  D WRAPUP
  1.  Q
  1.  ;
  1. DELETE ; Delete existing authorization
  1.  ; Called from option FBSH DELETE AUTH
  1.  D SETUP
  1.  I 'FBPOP F  D  Q:'$G(DFN)
  1.  . ; select patient
  1.  . D PAT Q:'$G(DFN)
  1.  . ; select existing authorization
  1.  . S FBPROG(0)=FBPROG
  1.  . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
  1.  . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
  1.  . I FTP'="" D
  1.  . . N FBY
  1.  . . S (DA,FBAAADA)=FTP,DA(1)=DFN
  1.  . . ; confirm
  1.  . . S FBY=$G(^FBAAA(DFN,1,FTP,0))
  1.  . . S DIR(0)="Y",DIR("A")="OK to DELETE the "_$$FMTE^XLFDT($P(FBY,U),2)_"-"_$$FMTE^XLFDT($P(FBY,U,2),2)_" authorization"
  1.  . . D ^DIR K DIR Q:'Y
  1.  . . ; queue MRA, update ADEL node
  1.  . . S FBX=$$QMRA(DFN,FBAAADA,"D")
  1.  . . S $P(^FBAAA(DFN,1,FBAAADA,"ADEL"),U,1,2)="1^"_DT
  1.  . ;
  1.  . ; unlock patient
  1.  . L -^FBAAA(DFN,FBPROG)
  1.  D WRAPUP
  1.  Q
  1.  ;
  1. REINSTA ; Reinstate deleted authorization
  1.  ; Called from option FBSH REINSTATE AUTH
  1.  D SETUP
  1.  I 'FBPOP F  D  Q:'$G(DFN)
  1.  . ; select patient
  1.  . D PAT Q:'$G(DFN)
  1.  . ; select existing deleted authorization
  1.  . S FBPROG(0)=FBPROG
  1.  . S FBPROG="I $P(^(0),U,3)=FBPROG(0),$P($G(^(""ADEL"")),U)"
  1.  . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
  1.  . I FTP'="" D
  1.  . . S (DA,FBAAADA)=FTP,DA(1)=DFN
  1.  . . ; confirm
  1.  . . ; save current data
  1.  . . S FBAOLD=$G(^FBAAA(DA(1),1,DA,0)),FBANEW=""
  1.  . . S FBBEGDT=$P(FBAOLD,U),FBENDDT=$P(FBAOLD,U,2)
  1.  . . ; display current data
  1.  . . W !!,"FROM DATE: ",$$FMTE^XLFDT(FBBEGDT)," (No Editing)"
  1.  . . ; edit TO DATE and check for conflicts
  1.  . . D TDATE Q:FBENDDT=""
  1.  . . ; update/edit fields
  1.  . . S DIE="^FBAAA("_DA(1)_",1,"
  1.  . . S DR=".02////^S X=FBENDDT;100////^S X=DUZ;S FBTYPE=FBPROG;.07;.04;.021"
  1.  . . D ^DIE K DIE
  1.  . . ; queue MRA, clear ADEL node
  1.  . . S FBX=$$QMRA(DFN,FBAAADA,"R")
  1.  . . K ^FBAAA(DFN,1,FBAAADA,"ADEL")
  1.  . ;
  1.  . ; unlock patient
  1.  . L -^FBAAA(DFN,FBPROG)
  1.  D WRAPUP
  1.  Q
  1.  ;
  1. SETUP ; initial setup - returns FBPOP = 1 when problem
  1.  D SITEP^FBAAUTL Q:FBPOP
  1.  S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1)
  1.  ;
  1.  S FBPROG=$O(^FBAA(161.8,"B","STATE HOME",0))
  1.  I 'FBPROG D  Q
  1.  . W $C(7)
  1.  . W !,"ERROR. STATE HOME not found in FEE BASIS PROGRAM (#161.8) file."
  1.  . W !,"Unable to process State Home authorization. Please contact IRM."
  1.  . S FBPOP=1
  1.  Q
  1.  ;
  1. PAT ; select patient
  1.  ; returns DFN as patient ien (or undef if not selected)
  1.  K DFN
  1.  W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC Q:Y'>0  S DFN=+Y
  1.  I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G PAT
  1.  I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.")
  1.  I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G PAT:$S($D(DIRUT):1,'Y:1,1:0)
  1.  ; if patient not in file #161 then add
  1.  I '$D(^FBAAA(DFN,0)) D   I Y'>0 W $C(7),!,"ERROR ADDING TO #161" K DFN Q
  1.  . S DA=DFN
  1.  . L +^FBAAA(DA):5 I '$T S Y="" Q
  1.  . K DD,DO S (X,DINUM)=DA
  1.  . S DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161
  1.  . D FILE^DICN K DIC,DINUM
  1.  . L -^FBAAA(DFN)
  1.  ; lock patient/program
  1.  L +^FBAAA(DFN,FBPROG):5 I '$T D  G PAT
  1.  . W $C(7),!,"ANOTHER USER IS EDITING THIS PATIENT & PROGRAM. PLEASE TRY AGAIN LATER."
  1.  Q
  1.  ;
  1. WRAPUP ; clean-up
  1.  K DFN,FB,FBAAADA,FBAAASKV,FBAADDYS,FBANEW,FBAOLD,FBBEGDT
  1.  K FBDMRA,FBENDDT,FBOPT,FBPOP,FBPOV,FBPROG,FBSITE,FTP,FBTYPE,FBX
  1.  K DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y
  1.  D GETAUTHK^FBAAUTL1
  1.  Q
  1.  ;
  1. BDATES ; get both from and to dates of new authorization
  1.  ; input
  1.  ;   DFN     patient ien in file 161
  1.  ;   FBPROG  program ien in file 
  1.  ; output
  1.  ;   FBBEGDT From Date, FileMan format, null if dates not selected
  1.  ;   FBENDDT To Date, FileMan format, null if dates not selected
  1.  ;
  1.  S %DT("A")="Enter FROM DATE: ",%DT="AEX"
  1.  D ^%DT K %DT I Y'>0 S (FBBEGDT,FBENDDT)="" Q
  1.  S FBBEGDT=Y
  1.  ;
  1.  S %DT("A")="Enter TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT
  1.  D ^%DT K %DT I Y'>0 S (FBBEGDT,FBENDDT)="" Q
  1.  S FBENDDT=Y
  1.  ; ensure dates do not conflict with existing authorization
  1.  S FBX=$$CONFLICT(DFN,FBPROG,FBBEGDT,FBENDDT,1)
  1.  I FBX D RCON(DFN,FBX) G BDATES
  1.  Q
  1.  ;
  1. TDATE ; get to date for existing authorization
  1.  ; input
  1.  ;   DFN     patient ien in file 161
  1.  ;   FBPROG  program ien in file
  1.  ;   FBBEGDT From Date, FileMan format
  1.  ;   FBENDDT (optional) current value of To Date
  1.  ; output
  1.  ;   FBENDDT To Date, FileMan format, null if date not selected
  1.  ;
  1.  S %DT("A")="Enter TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT
  1.  I $G(FBENDDT)]"" S %DT("B")=$$FMTE^XLFDT(FBENDDT)
  1.  D ^%DT K %DT I Y'>0 S FBENDDT="" Q
  1.  S FBENDDT=Y
  1.  ;
  1.  S FBX=$$CONFLICT(DFN,FBPROG,FBBEGDT,FBENDDT,0)
  1.  I FBX D RCON(DFN,FBX) G TDATE
  1.  Q
  1.  ;
  1. CONFLICT(DFN,PRG,FDT,TDT,NEWAUT) ; check for conflict with existing auth.
  1.  ; input
  1.  ;   DFN     - patient ien
  1.  ;   PRG     - program ien
  1.  ;   FDT     - from date in fileman format
  1.  ;   TDT     - to date in fileman format
  1.  ;   NEWAUT  - optional flag, true if dates for a new authorization
  1.  ; returns string with value =
  1.  ;   list of authorization iens (delimited by ^) that conflict OR
  1.  ;   null when no conflict found
  1.  ;
  1.  ; A conflict exists if
  1.  ;   1) the from date of a new authorization has already been used as
  1.  ;      the from date for an existing authorization (including deleted)
  1.  ;      for the same FEE program.
  1.  ;   OR
  1.  ;   2) the date range (FROM-TO) of this authorization overlaps the
  1.  ;      date range of a different, active (does not include deleted)
  1.  ;      authorization for the same FEE program. Note that the from date
  1.  ;      of one authorization can equal the to date of a different
  1.  ;      authorization and would not be in conflict.
  1.  ;
  1.  N FBI,FBRET,FBY
  1.  S FBRET=""
  1.  ; loop thru authorizations
  1.  S FBI=0 F  S FBI=$O(^FBAAA(DFN,1,FBI)) Q:'FBI  D
  1.  . S FBY=$G(^FBAAA(DFN,1,FBI,0))
  1.  . Q:$P(FBY,U,3)'=PRG  ; not program of interest
  1.  . Q:$P(FBY,U)=""!($P(FBY,U,2)="")  ; date missing - invalid
  1.  . ; if same from date and not new then must be the selected auth.
  1.  . ; and wouldn't conflict with self. if new then conflict found.
  1.  . I $P(FBY,U)=FDT S:NEWAUT FBRET=FBRET_FBI_U Q  ; same from date
  1.  . Q:$P($G(^FBAAA(DFN,1,FBI,"ADEL")),U)  ; austin deleted
  1.  . I FDT<$P(FBY,U,2),TDT>$P(FBY,U) S FBRET=FBRET_FBI_U  ; conflict
  1.  Q FBRET
  1.  ;
  1. RCON(DFN,LIST) ; Report Conflicts
  1.  N CNT,FBA,FBFD,FBI,FBIEN,FBP
  1.  S CNT=$L(LIST,U)-1
  1.  W $C(7)
  1.  W !!,"The specified dates conflict with other authorization(s)."
  1.  W !,"Please specify different dates for this authorization or"
  1.  W !,"remove the conflict by first editing the other authorization(s)."
  1.  W !!,"Conflict with  FROM DATE",?30,"TO DATE",?45,"PURPOSE OF VISIT"
  1.  F FBP=1:1 S FBI=$P(LIST,U,FBP) Q:FBI=""  D
  1.  . S FBFD=$P($G(^FBAAA(DFN,1,FBI,0)),U)
  1.  . Q:FBFD=""
  1.  . S FBA(FBFD)=FBI
  1.  S FBFD="" F  S FBFD=$O(FBA(FBFD)) Q:FBFD=""  D
  1.  . S FBI=FBA(FBFD)
  1.  . S FBIEN=FBI_","_DFN_","
  1.  . W !
  1.  . I $P($G(^FBAAA(DFN,1,FBI,"ADEL")),U)]"" D
  1.  . . W !,?2,"**Austin Deleted** - Use Reinstate to reuse this From Date"
  1.  . W ?15,$$GET1^DIQ(161.01,FBIEN,.01)
  1.  . W ?30,$$GET1^DIQ(161.01,FBIEN,.02)
  1.  . W ?45,$$GET1^DIQ(161.01,FBIEN,.07)
  1.  W !
  1.  Q
  1.  ;
  1. QMRA(DFN,AUT,TYP) ; Queue MRA for transmission to Austin
  1.  ; input
  1.  ;   DFN - patient ien (file 2)
  1.  ;   AUT - authorization ien (file 161.01)
  1.  ;   TYP - type of MRA (A, C, D, or R)
  1.  ; returns ien of MRA (file 161.26)
  1.  N DD,DO,DIC,DLAYGO
  1.  S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN
  1.  S DIC("DR")="1///^S X=""P"";2///^S X=AUT;3///^S X=TYP"
  1.  K DD,DO D FILE^DICN K DIC,DLAYGO
  1.  Q +Y
  1.  ;
  1. POV ; get purpose of visit
  1.  N DIR,DA,FBTYPE
  1.  S FBPOV=""
  1.  S FBTYPE=FBPROG
  1.  S DIR(0)="161.01,.07"
  1.  D ^DIR Q:$D(DIRUT)
  1.  S FBPOV=Y
  1.  Q
  1.  ;
  1.  ;FBSHAUT