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