| 1 | FBSHAUT ;WCIOFO/SAB-ENTER/EDIT STATE HOME AUTHORIZATION ;2/9/1999
|
|---|
| 2 | ;;3.5;FEE BASIS;**13**;JAN 30, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ADD ; Enter new authorization
|
|---|
| 6 | ; Called from option FBSH ENTER AUTH
|
|---|
| 7 | D SETUP
|
|---|
| 8 | I 'FBPOP F D Q:'$G(DFN)
|
|---|
| 9 | . ; select patient
|
|---|
| 10 | . D PAT Q:'$G(DFN)
|
|---|
| 11 | . ; show patient demographics
|
|---|
| 12 | . S FBPROG(0)=FBPROG
|
|---|
| 13 | . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
|
|---|
| 14 | . D ^FBAADEM
|
|---|
| 15 | . S FBPROG=FBPROG(0)
|
|---|
| 16 | . ; get dates
|
|---|
| 17 | . D BDATES
|
|---|
| 18 | . I FBBEGDT]"" D
|
|---|
| 19 | . . ; add/edit authorization
|
|---|
| 20 | . . S DA(1)=DFN,X=FBBEGDT
|
|---|
| 21 | . . S DIC="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",DLAYGO=161
|
|---|
| 22 | . . S DIC("DR")=".02////^S X=FBENDDT;.03////^S X=FBPROG;.095////4;100////^S X=DUZ;S FBTYPE=FBPROG;.07"
|
|---|
| 23 | . . S DIC("P")=$P(^DD(161,1,0),U,2)
|
|---|
| 24 | . . K DD,DO D FILE^DICN K DIC,DLAYGO
|
|---|
| 25 | . . I Y'>0 W $C(7),!,"AUTH. NOT ADDED" Q
|
|---|
| 26 | . . S (DA,FBAAADA)=+Y
|
|---|
| 27 | . . ; edit remaining fields
|
|---|
| 28 | . . S DIE="^FBAAA("_DA(1)_",1,"
|
|---|
| 29 | . . S DR=".04;.021"
|
|---|
| 30 | . . D ^DIE K DIE
|
|---|
| 31 | . . ; queue MRA
|
|---|
| 32 | . . S FBX=$$QMRA(DFN,FBAAADA,"A")
|
|---|
| 33 | . ;
|
|---|
| 34 | . ; unlock patient
|
|---|
| 35 | . L -^FBAAA(DFN,FBPROG)
|
|---|
| 36 | D WRAPUP
|
|---|
| 37 | Q
|
|---|
| 38 | ;
|
|---|
| 39 | CHANGE ; Change existing authorization
|
|---|
| 40 | ; Called from option FBSH CHANGE AUTH
|
|---|
| 41 | D SETUP
|
|---|
| 42 | I 'FBPOP F D Q:'$G(DFN)
|
|---|
| 43 | . ; select patient
|
|---|
| 44 | . D PAT Q:'$G(DFN)
|
|---|
| 45 | . ; select existing authorization
|
|---|
| 46 | . S FBPROG(0)=FBPROG
|
|---|
| 47 | . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
|
|---|
| 48 | . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
|
|---|
| 49 | . I FTP'="" D
|
|---|
| 50 | . . S (DA,FBAAADA)=FTP,DA(1)=DFN
|
|---|
| 51 | . . I $P($G(FBDMRA),U) W $C(7),!,"AUTH IS AUSTIN DELETED. USE THE REINSTATE OPTION TO CHANGE IT." Q
|
|---|
| 52 | . . ; save current data
|
|---|
| 53 | . . S FBAOLD=$G(^FBAAA(DA(1),1,DA,0)),FBANEW=""
|
|---|
| 54 | . . S FBBEGDT=$P(FBAOLD,U),FBENDDT=$P(FBAOLD,U,2)
|
|---|
| 55 | . . ; display current data
|
|---|
| 56 | . . W !!,"FROM DATE: ",$$FMTE^XLFDT(FBBEGDT)," (No Editing)"
|
|---|
| 57 | . . ; edit TO DATE and check for conflicts
|
|---|
| 58 | . . D TDATE Q:FBENDDT=""
|
|---|
| 59 | . . ; update/edit fields
|
|---|
| 60 | . . S DIE="^FBAAA("_DA(1)_",1,"
|
|---|
| 61 | . . S DR=".02////^S X=FBENDDT;100////^S X=DUZ;S FBTYPE=FBPROG;.07;.04;.021"
|
|---|
| 62 | . . D ^DIE K DIE
|
|---|
| 63 | . . ; if TO DATE or PURPOSE OF VISIT changed then queue MRA
|
|---|
| 64 | . . S FBANEW=$G(^FBAAA(DA(1),1,DA,0))
|
|---|
| 65 | . . I $P(FBANEW,U,2)'=$P(FBAOLD,U,2)!($P(FBANEW,U,7)'=$P(FBAOLD,U,7)) D
|
|---|
| 66 | . . . ; queue MRA
|
|---|
| 67 | . . . S FBX=$$QMRA(DFN,FBAAADA,"C")
|
|---|
| 68 | . ;
|
|---|
| 69 | . ; unlock patient
|
|---|
| 70 | . L -^FBAAA(DFN,FBPROG)
|
|---|
| 71 | D WRAPUP
|
|---|
| 72 | Q
|
|---|
| 73 | ;
|
|---|
| 74 | DELETE ; Delete existing authorization
|
|---|
| 75 | ; Called from option FBSH DELETE AUTH
|
|---|
| 76 | D SETUP
|
|---|
| 77 | I 'FBPOP F D Q:'$G(DFN)
|
|---|
| 78 | . ; select patient
|
|---|
| 79 | . D PAT Q:'$G(DFN)
|
|---|
| 80 | . ; select existing authorization
|
|---|
| 81 | . S FBPROG(0)=FBPROG
|
|---|
| 82 | . S FBPROG="I $P(^(0),U,3)=FBPROG(0)"
|
|---|
| 83 | . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
|
|---|
| 84 | . I FTP'="" D
|
|---|
| 85 | . . N FBY
|
|---|
| 86 | . . S (DA,FBAAADA)=FTP,DA(1)=DFN
|
|---|
| 87 | . . ; confirm
|
|---|
| 88 | . . S FBY=$G(^FBAAA(DFN,1,FTP,0))
|
|---|
| 89 | . . S DIR(0)="Y",DIR("A")="OK to DELETE the "_$$FMTE^XLFDT($P(FBY,U),2)_"-"_$$FMTE^XLFDT($P(FBY,U,2),2)_" authorization"
|
|---|
| 90 | . . D ^DIR K DIR Q:'Y
|
|---|
| 91 | . . ; queue MRA, update ADEL node
|
|---|
| 92 | . . S FBX=$$QMRA(DFN,FBAAADA,"D")
|
|---|
| 93 | . . S $P(^FBAAA(DFN,1,FBAAADA,"ADEL"),U,1,2)="1^"_DT
|
|---|
| 94 | . ;
|
|---|
| 95 | . ; unlock patient
|
|---|
| 96 | . L -^FBAAA(DFN,FBPROG)
|
|---|
| 97 | D WRAPUP
|
|---|
| 98 | Q
|
|---|
| 99 | ;
|
|---|
| 100 | REINSTA ; Reinstate deleted authorization
|
|---|
| 101 | ; Called from option FBSH REINSTATE AUTH
|
|---|
| 102 | D SETUP
|
|---|
| 103 | I 'FBPOP F D Q:'$G(DFN)
|
|---|
| 104 | . ; select patient
|
|---|
| 105 | . D PAT Q:'$G(DFN)
|
|---|
| 106 | . ; select existing deleted authorization
|
|---|
| 107 | . S FBPROG(0)=FBPROG
|
|---|
| 108 | . S FBPROG="I $P(^(0),U,3)=FBPROG(0),$P($G(^(""ADEL"")),U)"
|
|---|
| 109 | . D GETAUTH^FBAAUTL1 S FBPROG=FBPROG(0)
|
|---|
| 110 | . I FTP'="" D
|
|---|
| 111 | . . S (DA,FBAAADA)=FTP,DA(1)=DFN
|
|---|
| 112 | . . ; confirm
|
|---|
| 113 | . . ; save current data
|
|---|
| 114 | . . S FBAOLD=$G(^FBAAA(DA(1),1,DA,0)),FBANEW=""
|
|---|
| 115 | . . S FBBEGDT=$P(FBAOLD,U),FBENDDT=$P(FBAOLD,U,2)
|
|---|
| 116 | . . ; display current data
|
|---|
| 117 | . . W !!,"FROM DATE: ",$$FMTE^XLFDT(FBBEGDT)," (No Editing)"
|
|---|
| 118 | . . ; edit TO DATE and check for conflicts
|
|---|
| 119 | . . D TDATE Q:FBENDDT=""
|
|---|
| 120 | . . ; update/edit fields
|
|---|
| 121 | . . S DIE="^FBAAA("_DA(1)_",1,"
|
|---|
| 122 | . . S DR=".02////^S X=FBENDDT;100////^S X=DUZ;S FBTYPE=FBPROG;.07;.04;.021"
|
|---|
| 123 | . . D ^DIE K DIE
|
|---|
| 124 | . . ; queue MRA, clear ADEL node
|
|---|
| 125 | . . S FBX=$$QMRA(DFN,FBAAADA,"R")
|
|---|
| 126 | . . K ^FBAAA(DFN,1,FBAAADA,"ADEL")
|
|---|
| 127 | . ;
|
|---|
| 128 | . ; unlock patient
|
|---|
| 129 | . L -^FBAAA(DFN,FBPROG)
|
|---|
| 130 | D WRAPUP
|
|---|
| 131 | Q
|
|---|
| 132 | ;
|
|---|
| 133 | SETUP ; initial setup - returns FBPOP = 1 when problem
|
|---|
| 134 | D SITEP^FBAAUTL Q:FBPOP
|
|---|
| 135 | S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1)
|
|---|
| 136 | ;
|
|---|
| 137 | S FBPROG=$O(^FBAA(161.8,"B","STATE HOME",0))
|
|---|
| 138 | I 'FBPROG D Q
|
|---|
| 139 | . W $C(7)
|
|---|
| 140 | . W !,"ERROR. STATE HOME not found in FEE BASIS PROGRAM (#161.8) file."
|
|---|
| 141 | . W !,"Unable to process State Home authorization. Please contact IRM."
|
|---|
| 142 | . S FBPOP=1
|
|---|
| 143 | Q
|
|---|
| 144 | ;
|
|---|
| 145 | PAT ; select patient
|
|---|
| 146 | ; returns DFN as patient ien (or undef if not selected)
|
|---|
| 147 | K DFN
|
|---|
| 148 | W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC Q:Y'>0 S DFN=+Y
|
|---|
| 149 | I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G PAT
|
|---|
| 150 | 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.")
|
|---|
| 151 | 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)
|
|---|
| 152 | ; if patient not in file #161 then add
|
|---|
| 153 | I '$D(^FBAAA(DFN,0)) D I Y'>0 W $C(7),!,"ERROR ADDING TO #161" K DFN Q
|
|---|
| 154 | . S DA=DFN
|
|---|
| 155 | . L +^FBAAA(DA):5 I '$T S Y="" Q
|
|---|
| 156 | . K DD,DO S (X,DINUM)=DA
|
|---|
| 157 | . S DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161
|
|---|
| 158 | . D FILE^DICN K DIC,DINUM
|
|---|
| 159 | . L -^FBAAA(DFN)
|
|---|
| 160 | ; lock patient/program
|
|---|
| 161 | L +^FBAAA(DFN,FBPROG):5 I '$T D G PAT
|
|---|
| 162 | . W $C(7),!,"ANOTHER USER IS EDITING THIS PATIENT & PROGRAM. PLEASE TRY AGAIN LATER."
|
|---|
| 163 | Q
|
|---|
| 164 | ;
|
|---|
| 165 | WRAPUP ; clean-up
|
|---|
| 166 | K DFN,FB,FBAAADA,FBAAASKV,FBAADDYS,FBANEW,FBAOLD,FBBEGDT
|
|---|
| 167 | K FBDMRA,FBENDDT,FBOPT,FBPOP,FBPROG,FBSITE,FTP,FBTYPE,FBX
|
|---|
| 168 | K DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,X,Y
|
|---|
| 169 | Q
|
|---|
| 170 | ;
|
|---|
| 171 | BDATES ; get both from and to dates of new authorization
|
|---|
| 172 | ; input
|
|---|
| 173 | ; DFN patient ien in file 161
|
|---|
| 174 | ; FBPROG program ien in file
|
|---|
| 175 | ; output
|
|---|
| 176 | ; FBBEGDT From Date, FileMan format, null if dates not selected
|
|---|
| 177 | ; FBENDDT To Date, FileMan format, null if dates not selected
|
|---|
| 178 | ;
|
|---|
| 179 | S %DT("A")="Enter FROM DATE: ",%DT="AEX"
|
|---|
| 180 | D ^%DT K %DT I Y'>0 S (FBBEGDT,FBENDDT)="" Q
|
|---|
| 181 | S FBBEGDT=Y
|
|---|
| 182 | ;
|
|---|
| 183 | S %DT("A")="Enter TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT
|
|---|
| 184 | D ^%DT K %DT I Y'>0 S (FBBEGDT,FBENDDT)="" Q
|
|---|
| 185 | S FBENDDT=Y
|
|---|
| 186 | ; ensure dates do not conflict with existing authorization
|
|---|
| 187 | S FBX=$$CONFLICT(DFN,FBPROG,FBBEGDT,FBENDDT,1)
|
|---|
| 188 | I FBX D RCON(DFN,FBX) G BDATES
|
|---|
| 189 | Q
|
|---|
| 190 | ;
|
|---|
| 191 | TDATE ; get to date for existing authorization
|
|---|
| 192 | ; input
|
|---|
| 193 | ; DFN patient ien in file 161
|
|---|
| 194 | ; FBPROG program ien in file
|
|---|
| 195 | ; FBBEGDT From Date, FileMan format
|
|---|
| 196 | ; FBENDDT (optional) current value of To Date
|
|---|
| 197 | ; output
|
|---|
| 198 | ; FBENDDT To Date, FileMan format, null if date not selected
|
|---|
| 199 | ;
|
|---|
| 200 | S %DT("A")="Enter TO DATE: ",%DT="AEX",%DT(0)=FBBEGDT
|
|---|
| 201 | I $G(FBENDDT)]"" S %DT("B")=$$FMTE^XLFDT(FBENDDT)
|
|---|
| 202 | D ^%DT K %DT I Y'>0 S FBENDDT="" Q
|
|---|
| 203 | S FBENDDT=Y
|
|---|
| 204 | ;
|
|---|
| 205 | S FBX=$$CONFLICT(DFN,FBPROG,FBBEGDT,FBENDDT,0)
|
|---|
| 206 | I FBX D RCON(DFN,FBX) G TDATE
|
|---|
| 207 | Q
|
|---|
| 208 | ;
|
|---|
| 209 | CONFLICT(DFN,PRG,FDT,TDT,NEWAUT) ; check for conflict with existing auth.
|
|---|
| 210 | ; input
|
|---|
| 211 | ; DFN - patient ien
|
|---|
| 212 | ; PRG - program ien
|
|---|
| 213 | ; FDT - from date in fileman format
|
|---|
| 214 | ; TDT - to date in fileman format
|
|---|
| 215 | ; NEWAUT - optional flag, true if dates for a new authorization
|
|---|
| 216 | ; returns string with value =
|
|---|
| 217 | ; list of authorization iens (delimited by ^) that conflict OR
|
|---|
| 218 | ; null when no conflict found
|
|---|
| 219 | ;
|
|---|
| 220 | ; A conflict exists if
|
|---|
| 221 | ; 1) the from date of a new authorization has already been used as
|
|---|
| 222 | ; the from date for an existing authorization (including deleted)
|
|---|
| 223 | ; for the same FEE program.
|
|---|
| 224 | ; OR
|
|---|
| 225 | ; 2) the date range (FROM-TO) of this authorization overlaps the
|
|---|
| 226 | ; date range of a different, active (does not include deleted)
|
|---|
| 227 | ; authorization for the same FEE program. Note that the from date
|
|---|
| 228 | ; of one authorization can equal the to date of a different
|
|---|
| 229 | ; authorization and would not be in conflict.
|
|---|
| 230 | ;
|
|---|
| 231 | N FBI,FBRET,FBY
|
|---|
| 232 | S FBRET=""
|
|---|
| 233 | ; loop thru authorizations
|
|---|
| 234 | S FBI=0 F S FBI=$O(^FBAAA(DFN,1,FBI)) Q:'FBI D
|
|---|
| 235 | . S FBY=$G(^FBAAA(DFN,1,FBI,0))
|
|---|
| 236 | . Q:$P(FBY,U,3)'=PRG ; not program of interest
|
|---|
| 237 | . Q:$P(FBY,U)=""!($P(FBY,U,2)="") ; date missing - invalid
|
|---|
| 238 | . ; if same from date and not new then must be the selected auth.
|
|---|
| 239 | . ; and wouldn't conflict with self. if new then conflict found.
|
|---|
| 240 | . I $P(FBY,U)=FDT S:NEWAUT FBRET=FBRET_FBI_U Q ; same from date
|
|---|
| 241 | . Q:$P($G(^FBAAA(DFN,1,FBI,"ADEL")),U) ; austin deleted
|
|---|
| 242 | . I FDT<$P(FBY,U,2),TDT>$P(FBY,U) S FBRET=FBRET_FBI_U ; conflict
|
|---|
| 243 | Q FBRET
|
|---|
| 244 | ;
|
|---|
| 245 | RCON(DFN,LIST) ; Report Conflicts
|
|---|
| 246 | N CNT,FBA,FBFD,FBI,FBIEN,FBP
|
|---|
| 247 | S CNT=$L(LIST,U)-1
|
|---|
| 248 | W $C(7)
|
|---|
| 249 | W !!,"The specified dates conflict with other authorization(s)."
|
|---|
| 250 | W !,"Please specify different dates for this authorization or"
|
|---|
| 251 | W !,"remove the conflcit by first editing the other authorization(s)."
|
|---|
| 252 | W !!,"Conflict with FROM DATE",?30,"TO DATE",?45,"PURPOSE OF VISIT"
|
|---|
| 253 | F FBP=1:1 S FBI=$P(LIST,U,FBP) Q:FBI="" D
|
|---|
| 254 | . S FBFD=$P($G(^FBAAA(DFN,1,FBI,0)),U)
|
|---|
| 255 | . Q:FBFD=""
|
|---|
| 256 | . S FBA(FBFD)=FBI
|
|---|
| 257 | S FBFD="" F S FBFD=$O(FBA(FBFD)) Q:FBFD="" D
|
|---|
| 258 | . S FBI=FBA(FBFD)
|
|---|
| 259 | . S FBIEN=FBI_","_DFN_","
|
|---|
| 260 | . W !
|
|---|
| 261 | . I $P($G(^FBAAA(DFN,1,FBI,"ADEL")),U)]"" D
|
|---|
| 262 | . . W !,?2,"**Austin Deleted** - Use Reinstate to reuse this From Date"
|
|---|
| 263 | . W ?15,$$GET1^DIQ(161.01,FBIEN,.01)
|
|---|
| 264 | . W ?30,$$GET1^DIQ(161.01,FBIEN,.02)
|
|---|
| 265 | . W ?45,$$GET1^DIQ(161.01,FBIEN,.07)
|
|---|
| 266 | W !
|
|---|
| 267 | Q
|
|---|
| 268 | ;
|
|---|
| 269 | QMRA(DFN,AUT,TYP) ; Queue MRA for transmission to Austin
|
|---|
| 270 | ; input
|
|---|
| 271 | ; DFN - patient ien (file 2)
|
|---|
| 272 | ; AUT - authorization ien (file 161.01)
|
|---|
| 273 | ; TYP - type of MRA (A, C, D, or R)
|
|---|
| 274 | ; returns ien of MRA (file 161.26)
|
|---|
| 275 | N DD,DO,DIC,DLAYGO
|
|---|
| 276 | S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN
|
|---|
| 277 | S DIC("DR")="1///^S X=""P"";2///^S X=AUT;3///^S X=TYP"
|
|---|
| 278 | K DD,DO D FILE^DICN K DIC,DLAYGO
|
|---|
| 279 | Q +Y
|
|---|
| 280 | ;
|
|---|
| 281 | ;FBSHAUT
|
|---|
