ACHSBMC ; IHS/ITSC/PMF - RCIS INTERFACE SUBROUTINES ;
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,10,11,13,16,22,23**;JUN 11,2001;Build 43
;IHS/SET/GTH ACHS*3.1*5 12/06/2002 -Remove ref to non-package global
;3.1*10 4.19.04 IHS/OIT/FCJ ADD OPT FOR CALLS FR THE DEN PKG
; TO SET DEFAULT VARS & CLOSE THE REF AFTER ISSUED DEN
;3.1*11 8.24.04 IHS/OIT/FCJ REF NOT REQ W/IN 180 DAYS OF RCIS ST DT
;3.1*11 8.24.04 IHS/OIT/FCJ TST FOR RCIS VER AND MULT DEN/PRV
;3.1*13 8.15.05 IHS/OIT/FCJ PARAMETER TST FOR REQ'D REF FOR PO & DEN TST
;3.1*13 8.30.06 IHS/OIT/FCJ ADD UPDATE FOR APPEAL, MULT CHG TO PASS SQA
;ACHS*3.1*16 11/3/2009 IHS.OIT.FCJ FX FOR FY 10
;ACHS*3.1*22 IHS.OIT.FCJ ADDED DELETE DX FR RCIS AND SELECTING APPRV REFS
;ACHS*3.1*23 IHS.OIT.FCJ ADDED SELECTING APPROVED FR DENIAL OPTION
;
ADD ;EP - link P.O. to referral
I '$$LINK W !,"The link to the Referral system is not on." Q
ADD1 ;
D ^ACHSUD
Q:'$D(ACHSDIEN)
I $$DOC^ACHS(0,12)=4 W *7,!,"This document has been canceled." G ADD1
;I $$DOC^ACHS(2,7) W *7,!,"This document is already linked to Referral ",$P($G(^BMCREF($$DOC^ACHS(2,7),0)),U,2),"." G ADD1;IHS/SET/GTH ACHS*3.1*5 12/06/2002
I $$DOC^ACHS(2,7) W *7,!,"This document is already linked to Referral ",$$GET1^DIQ(90001,$$DOC^ACHS(2,7),.02),"." G ADD1 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
N ACHS
S ACHS="",ACHS("ADD")=1 ; This acts as a flag in GETREF().
ADD2 ;
D GETREF(.ACHS)
Q:$D(DUOUT)!$D(DTOUT)!(ACHS<1)
I '($$DOC^ACHS(0,22)=DFN) D G ADD2
.W *7,!,"The patient in the Referral is '",$P($G(^DPT(DFN,0)),U),"'."
.W !,"The patient in the P.O. is '",$S($$DOC^ACHS(0,22):$P($G(^DPT($$DOC^ACHS(0,22),0)),U),1:"<missing>"),"'."
.Q
;GET REF IEN
I '$$DIE^ACHS("62////"_ACHS) W *7,!,"Addition of Referral failed in routine ACHSBMC." D RTRN^ACHS Q
S ACHSREF=ACHS
D AUTH,DX,PX
Q
; ------------------------
AUTH ;EP - Update the P.O. status in REF
; ACHSREF = Ref IEN Req
; ACHSDIEN = P.O. IEN, "D" level Req
;
I '$$LINK Q
I $$DOC^ACHS(0,12)=4 D Q ; If P.O. is canceled, delete.
.D AUTH^BMCCHS(ACHSREF,ACHSDIEN,"D")
.K DIC,DIADD,LAYGO ; ACHS*3.1*23
.I '$$DIE^ACHS("62///@")
N ACHS,ACHSTIEN
S ACHS(.02)=$$DOC^ACHS(0,9)
S ACHS(.03)=$$DOC^ACHS("ZA",1)
I 'ACHS(.03) S ACHS(.03)=$$DOC^ACHS("PA",1)
S ACHS(.04)="",ACHSTIEN=0
F S ACHSTIEN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN)) Q:'(ACHSTIEN=+ACHSTIEN) I $$TRAN^ACHS(0,5)="F" S ACHS(.04)=1 Q
S ACHSTIEN=0,ACHS(.06)=9999999,ACHS(.07)=0
F S ACHSTIEN=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSTIEN)) Q:'(ACHSTIEN=+ACHSTIEN) D
.I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,2)<ACHS(.06) S ACHS(.06)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,2)
.I $P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,3)>ACHS(.07) S ACHS(.07)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,3)
I ACHS(.06)=9999999 K ACHS(.06)
I ACHS(.07)=0 K ACHS(.07)
;ACHS*3.1*16 11/3/2009 IHS.OIT.FCJ FX FOR FY 10
;S ACHS(.08)="0"_$$DOC^ACHS(0,14)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1)
S ACHS(.08)=$E($$DOC^ACHS(0,27),3,4)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1)
S ACHS(.09)=$$DOC^ACHS(0,8)
;
D AUTH^BMCCHS(ACHSREF,ACHSDIEN,"P",.ACHS)
K DIC,DIADD,LAYGO ; ACHS*3.1*23
I '$$DIE^ACHS("62////"_ACHSREF)
Q
; ----------------------------
DX ;EP - Trans DX info to RCIS.
; ACHSDIEN = P.O. IEN, "D" level req
;
I '$$LINK Q
N ACHS,ACHSDX
S ACHS(.02)=$$DOC^ACHS(0,22) ; Patient DFN
S ACHS(.03)=$$DOC^ACHS(2,7) ; Referral IEN
S ACHS(.04)="F",ACHS(.06)=""
S ACHSDX=0
F S ACHSDX=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSDX)) Q:'(ACHSDX=+ACHSDX) D
.S ACHS(.01)=+$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSDX,0)),U)
.;The first DX on the EOBR is the primary DX.
.S ACHS(.05)=$S(ACHSDX=1:"P",1:"S")
.D DXA^BMCCHS(ACHS(.03),.ACHS)
K DIC,DLAYGO ; ACHS*3.1*23
Q
DX1 ;EP;UPDATE FOR ICD9 FIX ;ACHS*3.1*22 ADDED CALL TO DELETE DX IN RCIS
; ACHSDIEN = P.O. IEN, "D" level req
;
N ACHS
S ACHS(.02)=$$DOC^ACHS(0,22) ; Patient DFN
S ACHS(.03)=$$DOC^ACHS(2,7) ; Referral IEN
S ACHS(.04)="F",ACHS(.06)=""
;ADD
S ACHS(.01)=ACHSICDN
;The first DX on the EOBR is the primary DX.
S ACHS(.05)=$S(ACHSDX=1:"P",1:"S")
D DXA^BMCCHS(ACHS(.03),.ACHS)
;DEL
S ACHS(.01)=ACHSICDO
D DXD^BMCCHS(ACHS(.03),.ACHS)
K DIC,DLAYGO ; ACHS*3.1*23
Q
; ----------------------------
GETREF(ACHS) ;EP - select ref, retrieve info
I '$$LINK Q
GETREF0 W !
N DIC,D
; In DIC("S"), the Ref must be [C]HS and [A]ctive.
S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
I $G(ACHS),$D(^BMCREF(ACHS)) D SET^BMCCHS(ACHS,.ACHS) S DIC("B")=$P($G(^DPT(ACHS(.03),0)),U)
;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ ADD NXT SECT TO ALLOW SEL REF FOR DEN
GETREF1 ;
D ^DIC
Q:$D(DUOUT) ;ACHS*3.1*23
I $G(ACHD("FAC"))'="" D GETREF3
E D GETREF2
G:$D(DUOUT) GETREF0 ;ACHS*3.1*23
I Y=1,$$GET1^DIQ(90001.31,DUZ(2),4104)="NO" Q ;ACHS*3.1*23
;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ REF NOT REQ IF W/IN 180 DAYS OF IMPLEMENTING RCIS
Q:Y<1 ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ
;Q:(Y<1)!('$G(ACHS)) ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ
D GETREF4
D EN^XBVK("BMC")
Q
GETREF2 ; TEST FOR ADDING NEW PO'S
;D ^DIC ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ CALLED ABOVE
I Y<1 D Q
. Q:$D(DUOUT)!$D(DTOUT)!($G(ACHS("ADD")))
. N A,I,V
. ;S Y=$P($G(^BMCPARM(DUZ(2),0)),U,24);IHS/SET/GTH ACHS*3.1*5 12/06/2002
. S Y=$$GET1^DIQ(90001.31,DUZ(2),.24,"I") ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
. I Y,$$FMDIFF^XLFDT(DT,Y)<180,$$DIR^XBDIR("Y","Are you sure you want to enter a P.O. w/o a Referral","N","","","",1) K ACHS,ACHSREF Q
. ;ACHS*3.1*13 8.15.05 IHS/OIT/FCJ ADD NXT 2 LNS TO TST PAR REQ REF FOR PO
. S Y=$$GET1^DIQ(90001.31,DUZ(2),4104)
. I Y="NO",$$DIR^XBDIR("Y","Are you sure you want to enter a P.O. w/o a Referral","N","","","",1) K ACHS,ACHSREF Q
. Q:$D(DUOUT) ;ACHS*3.1*23
. W *7,!!,"You must have a CHS referral to enter a P.O.",!!
. S DUOUT=$$DIR^XBDIR("E","Press RETURN...")
Q
;
GETREF3 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ TST CALL FR DEN PKG ADDED NXT 3 LINES
I Y<1 D Q
. Q:$D(DUOUT)!$D(DTOUT)
. W *7,!!,"A Referral has not been entered.",!!
Q
;
GETREF4 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ ADD LN LABEL NXT SEC
S ACHS=+Y
D SET^BMCCHS(ACHS,.ACHS)
;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ ADDED TEST FOR DEN AND I DEN..
;I ($G(ACHS(.04))'="C")!($G(ACHS(.15))'="A") D G GETREF1 ;ACHS*3.1*10 4.19.04
;ACHS*3.1*22 IHS.OIT.FCJ ADDED TEST FOR APPROVED AND ALLOWING PO'S FOR CLOSED REF
;I $G(ACHD("FAC"))="",($G(ACHS(.04))'="C")!($G(ACHS(.15))'="A") D G GETREF1 ;ACHS*3.1*10 4.19.04
;.W !!," This must be a Referral that is 'ACTIVE/APPROVED' and 'CHS FACILITY'."
;.W !,"You have selected a Referral that is '",$$EXTSET^XBFUNC(90001,.15,$G(ACHS(.15))),"' and '",$$EXTSET^XBFUNC(90001,.04,$G(ACHS(.04))),"'.",!
I $G(ACHD("FAC"))="",$G(ACHS(.04))'="C" D G GETREF1
.W !,"You have selected a Referral that is Not a CHS Referral."
.W !,"Please select a CHS Referral",!
.S ACHS=0,Y=0 K DA
;ACHS*3.1*22 END OF CHANGES
;ACHS*3.1*13 8.15.05 IHS/OIT/FCJ ADD NXT 2 LINES FOR DEN # TEST
I $G(ACHD("FAC"))'="",$G(ACHSREF(1128))'="" D
.W !!," You have selected a Referral that already has a denial number, ",$G(ACHS(1128)),!
;ACHS*3.1*23 ADD APPROVED FOR DENIAL TEST
;I $G(ACHD("FAC"))'="",($G(ACHS(.04))="I")!($G(ACHS(.04))="N")!($G(ACHS(.15))'="A") D G GETREF0
I $G(ACHD("FAC"))'="",($G(ACHS(.04))="I")!($G(ACHS(.04))="N")!($G(ACHS(.15))="X")!($G(ACHS(.15))="C1") D G GETREF0
.W !!," This must be a Referral that is 'ACTIVE/APPROVED' and 'CHS FACILITY' or 'OTHER'."
.W !,"You have selected a Referral that is '",$$EXTSET^XBFUNC(90001,.15,$G(ACHS(.15))),"' and '",$$EXTSET^XBFUNC(90001,.04,$G(ACHS(.04))),"'.",!
.S ACHS=0
;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ END OF CHANGES
;ACHS*3.1*22 TEST FOR CLOSED REF CHCK TO CONTINUE
I $G(ACHD("FAC"))="",($G(ACHS(.15))="C1")!($G(ACHS(.15))="X") D G:Y=0 GETREF1
.W !,"You have selected a 'CLOSED' Referral."
.S DIR("A")="Do you wish to CONTINUE",DIR(0)="Y",DIR("B")="NO" D ^DIR K DIR I +Y>0 S Y=ACHS Q
.S ACHS=0,Y=0 K DA
S DFN=ACHS(.03),ACHSHRN=$$HRN^ACHS(DFN,DUZ(2))
S ACHSPROV=ACHS(.07)
S %=ACHS(.14)
I $L(%) S ACHSTYP=$S(%="I":1,%="O":3,1:"")
;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ CHG THE EDOS AND ADDED NXT 3 LINES
;I $G(ACHS(1105)) S ACHSEDOS=ACHS(1105) ;ACHS*3.1*10 4.21.04
S ACHSEDOS=$S($G(ACHS(1106)):ACHS(1106),$G(ACHS(1105)):ACHS(1105),1:"") ;ACHS*3.1*10 4.21.04
S ACHSDES=$E($G(ACHSREF(1201)),1,30) ;ACHS*3.1*11 8.24.04
S ACHSRMPC=$S($G(ACHS(.32))=1:"I",$G(ACHS(.32))=2:"II",$G(ACHS(.32))=3:"III",$G(ACHS(.32))=4:"IV",1:"") ;ACHS*3.1*10 4.21.04
S ACHSESDO=$G(ACHS(1101)) ;ACHS*3.1*10 4.21.04
Q
; ----------------------------
LINK() ;EP - Is link to RCIS on?
;Q +$P($G(^BMCPARM(DUZ(2),0)),U,4);IHS/SET/GTH ACHS*3.1*5 12/06/2002
Q $$GET1^DIQ(90001.31,DUZ(2),.04,"I") ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
; ----------------------------
VCHK() ;EP - VER OF RCIS
Q $$VERSION^XPDUTL("BMC") ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ
;
P(I,S,P) ;EP - Return Internal format of Referral with IEN of I,S, Piece P.
; FOR USE DURING DEVELOPMENT. RCIS WILL PROVIDE REQUIRED DATA ITEMS
Q $P($G(^BMCREF(I,S)),U,P)
;
; ----------------------------
PX ;EP - Transfer PX info to RCIS.
; ACHSDIEN = P.O. IEN at the "D" level
;
I '$$LINK Q
N ACHS,ACHSPX,ACHSPX1
S ACHS(.02)=$$DOC^ACHS(0,22) ; Patient DFN
S ACHS(.03)=$$DOC^ACHS(2,7) ; Referral IEN
S ACHS(.04)="F"
S ACHS(.06)=""
S ACHSPX=0
F S ACHSPX=$O(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX)) Q:'(ACHSPX=+ACHSPX) D
. S ACHS(.01)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX,0)),U)
. Q:'(ACHS(.01)["ICPT(")
. S ACHS(.01)=+ACHS(.01)
. ; The first PX on the EOBR is the primary PX.
. I $G(ACHSPX1) S ACHS(.05)="S"
. E S ACHS(.05)="P",ACHSPX1=1
. S ACHS(.07)=$P($G(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX,0)),U,4)
. D PXA^BMCCHS(ACHS(.03),.ACHS)
Q
; ----------------------------
;ACHS*3.1*13 8.30.06 IHS/OIT/FCJ ADDED APPEAL SECT
APPEAL ;EP -Update Referral appeal info
I '$$LINK Q
S ACHS(6116)=$P(ACHSREC,U) ;APPEAL DT
S ACHS(6117)=$P(ACHSREC,U,4) ;APPEAL RESOLVE DT
S ACHS(6118)=$P(ACHSREC,U,2) ;APPEAL STATUS
S ACHS(6119)=$P(ACHSREC,U,3) ;APPEAL LEVEL
S I=$P(^ACHSDENA(ACHS(6118),0),U)
S ACHS(1112)=$S(I="PAYED WITH ADDITIONAL MONEY":"A",I="APPEAL PENDING":"PA",I="REVERSED AFTER APPEAL":"A",I="UPHELD AFTER APPEAL":"D",1:"")
S ACHS(1113)=DT ;APPROVAL/DENIAL DT
S ACHS(1121)=DUZ ;CHS STAFF
S ACHS(1122)=DT ;Dt of denial
S ACHS(1128)=$P(^ACHSDEN(DUZ(2),"D",ACHSA,0),U) ; denial NUMBER
K S
I $$PATCH^XPDUTL("BMC*4.0*3") D APPEAL^BMCCHS1(.ACHS)
Q
;
STAT(S) ;EP - Update Referral status
; ACHSREF must contain the Referral IEN.
I '$$LINK Q
N ACHS
S ACHS(1112)=S
S ACHS(1113)=DT
;
I S="D" D
.S:$P(^ACHSDEN(DUZ(2),"D",ACHSA,100),U)="Y" ACHS(.07)=$P(^ACHSDEN(DUZ(2),"D",ACHSA,100),U,2) ;PRIM PROV
.S ACHS(.14)=$P(^ACHSDEN(DUZ(2),"D",ACHSA,100),U,10) ;INPAT/OUT
.S ACHS(.15)=$S(ACHS(.14)="O":"C1",1:"A")
.S ACHS(1106)=ACHDDOS ;DT OF SERVICE
.S ACHS(1113)=DT ;APPROVAL/DENIAL DATE
.S ACHS(1114)=ACHSREF(1114) ; denial reason.
.S ACHS(1121)=DUZ ; CHS STAFF
.S ACHS(1122)=DT ; Dt of denial
.S ACHS(1128)=ACHDNUM ; denial NUMBER
.;ACHS*3.1*11 9.27.04 IHS/ITSC/FCJ ADDED NXT SEC MULT DEN REASON/PROV
.;ACHS(200...) PROV ;ACHS(300...) REASON
.F X=200,300 I $D(^ACHSDEN(DUZ(2),"D",ACHSA,X)) D
..S CT=0,X1=0
..S CT=$S(X=200:4401,X=300:4301,1:"")
..F S X1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,X,X1)) Q:X1'?1N.N D
...S ACHS(CT)=$P(^ACHSDEN(DUZ(2),"D",ACHSA,X,X1,0),U)
...S CT=CT+1
.K X,X1,CT
.;ACHS*3.1*11 9.27.04 IHS/ITSC/FCJ END OF CHG
K S
D STAT^BMCCHS(ACHSREF,"P",.ACHS)
Q
; ----------------------------
ACHSBMC ; IHS/ITSC/PMF - RCIS INTERFACE SUBROUTINES ;
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**5,10,11,13,16,22,23**;JUN 11,2001;Build 43
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002 -Remove ref to non-package global
+3 ;3.1*10 4.19.04 IHS/OIT/FCJ ADD OPT FOR CALLS FR THE DEN PKG
+4 ; TO SET DEFAULT VARS & CLOSE THE REF AFTER ISSUED DEN
+5 ;3.1*11 8.24.04 IHS/OIT/FCJ REF NOT REQ W/IN 180 DAYS OF RCIS ST DT
+6 ;3.1*11 8.24.04 IHS/OIT/FCJ TST FOR RCIS VER AND MULT DEN/PRV
+7 ;3.1*13 8.15.05 IHS/OIT/FCJ PARAMETER TST FOR REQ'D REF FOR PO & DEN TST
+8 ;3.1*13 8.30.06 IHS/OIT/FCJ ADD UPDATE FOR APPEAL, MULT CHG TO PASS SQA
+9 ;ACHS*3.1*16 11/3/2009 IHS.OIT.FCJ FX FOR FY 10
+10 ;ACHS*3.1*22 IHS.OIT.FCJ ADDED DELETE DX FR RCIS AND SELECTING APPRV REFS
+11 ;ACHS*3.1*23 IHS.OIT.FCJ ADDED SELECTING APPROVED FR DENIAL OPTION
+12 ;
ADD ;EP - link P.O. to referral
+1 IF '$$LINK
WRITE !,"The link to the Referral system is not on."
QUIT
ADD1 ;
+1 DO ^ACHSUD
+2 IF '$DATA(ACHSDIEN)
QUIT
+3 IF $$DOC^ACHS(0,12)=4
WRITE *7,!,"This document has been canceled."
GOTO ADD1
+4 ;I $$DOC^ACHS(2,7) W *7,!,"This document is already linked to Referral ",$P($G(^BMCREF($$DOC^ACHS(2,7),0)),U,2),"." G ADD1;IHS/SET/GTH ACHS*3.1*5 12/06/2002
+5 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
IF $$DOC^ACHS(2,7)
WRITE *7,!,"This document is already linked to Referral ",$$GET1^DIQ(90001,$$DOC^ACHS(2,7),.02),"."
GOTO ADD1
+6 NEW ACHS
+7 ; This acts as a flag in GETREF().
SET ACHS=""
SET ACHS("ADD")=1
ADD2 ;
+1 DO GETREF(.ACHS)
+2 IF $DATA(DUOUT)!$DATA(DTOUT)!(ACHS<1)
QUIT
+3 IF '($$DOC^ACHS(0,22)=DFN)
Begin DoDot:1
+4 WRITE *7,!,"The patient in the Referral is '",$PIECE($GET(^DPT(DFN,0)),U),"'."
+5 WRITE !,"The patient in the P.O. is '",$SELECT($$DOC^ACHS(0,22):$PIECE($GET(^DPT($$DOC^ACHS(0,22),0)),U),1:"<missing>"),"'."
+6 QUIT
End DoDot:1
GOTO ADD2
+7 ;GET REF IEN
+8 IF '$$DIE^ACHS("62////"_ACHS)
WRITE *7,!,"Addition of Referral failed in routine ACHSBMC."
DO RTRN^ACHS
QUIT
+9 SET ACHSREF=ACHS
+10 DO AUTH
DO DX
DO PX
+11 QUIT
+12 ; ------------------------
AUTH ;EP - Update the P.O. status in REF
+1 ; ACHSREF = Ref IEN Req
+2 ; ACHSDIEN = P.O. IEN, "D" level Req
+3 ;
+4 IF '$$LINK
QUIT
+5 ; If P.O. is canceled, delete.
IF $$DOC^ACHS(0,12)=4
Begin DoDot:1
+6 DO AUTH^BMCCHS(ACHSREF,ACHSDIEN,"D")
+7 ; ACHS*3.1*23
KILL DIC,DIADD,LAYGO
+8 IF '$$DIE^ACHS("62///@")
End DoDot:1
QUIT
+9 NEW ACHS,ACHSTIEN
+10 SET ACHS(.02)=$$DOC^ACHS(0,9)
+11 SET ACHS(.03)=$$DOC^ACHS("ZA",1)
+12 IF 'ACHS(.03)
SET ACHS(.03)=$$DOC^ACHS("PA",1)
+13 SET ACHS(.04)=""
SET ACHSTIEN=0
+14 FOR
SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,"T",ACHSTIEN))
IF '(ACHSTIEN=+ACHSTIEN)
QUIT
IF $$TRAN^ACHS(0,5)="F"
SET ACHS(.04)=1
QUIT
+15 SET ACHSTIEN=0
SET ACHS(.06)=9999999
SET ACHS(.07)=0
+16 FOR
SET ACHSTIEN=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSTIEN))
IF '(ACHSTIEN=+ACHSTIEN)
QUIT
Begin DoDot:1
+17 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,2)<ACHS(.06)
SET ACHS(.06)=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,2)
+18 IF $PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,3)>ACHS(.07)
SET ACHS(.07)=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,0)),U,3)
End DoDot:1
+19 IF ACHS(.06)=9999999
KILL ACHS(.06)
+20 IF ACHS(.07)=0
KILL ACHS(.07)
+21 ;ACHS*3.1*16 11/3/2009 IHS.OIT.FCJ FX FOR FY 10
+22 ;S ACHS(.08)="0"_$$DOC^ACHS(0,14)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1)
+23 SET ACHS(.08)=$EXTRACT($$DOC^ACHS(0,27),3,4)_"-"_$$FC^ACHS(DUZ(2))_"-"_$$DOC^ACHS(0,1)
+24 SET ACHS(.09)=$$DOC^ACHS(0,8)
+25 ;
+26 DO AUTH^BMCCHS(ACHSREF,ACHSDIEN,"P",.ACHS)
+27 ; ACHS*3.1*23
KILL DIC,DIADD,LAYGO
+28 IF '$$DIE^ACHS("62////"_ACHSREF)
+29 QUIT
+30 ; ----------------------------
DX ;EP - Trans DX info to RCIS.
+1 ; ACHSDIEN = P.O. IEN, "D" level req
+2 ;
+3 IF '$$LINK
QUIT
+4 NEW ACHS,ACHSDX
+5 ; Patient DFN
SET ACHS(.02)=$$DOC^ACHS(0,22)
+6 ; Referral IEN
SET ACHS(.03)=$$DOC^ACHS(2,7)
+7 SET ACHS(.04)="F"
SET ACHS(.06)=""
+8 SET ACHSDX=0
+9 FOR
SET ACHSDX=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSDX))
IF '(ACHSDX=+ACHSDX)
QUIT
Begin DoDot:1
+10 SET ACHS(.01)=+$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,9,ACHSDX,0)),U)
+11 ;The first DX on the EOBR is the primary DX.
+12 SET ACHS(.05)=$SELECT(ACHSDX=1:"P",1:"S")
+13 DO DXA^BMCCHS(ACHS(.03),.ACHS)
End DoDot:1
+14 ; ACHS*3.1*23
KILL DIC,DLAYGO
+15 QUIT
DX1 ;EP;UPDATE FOR ICD9 FIX ;ACHS*3.1*22 ADDED CALL TO DELETE DX IN RCIS
+1 ; ACHSDIEN = P.O. IEN, "D" level req
+2 ;
+3 NEW ACHS
+4 ; Patient DFN
SET ACHS(.02)=$$DOC^ACHS(0,22)
+5 ; Referral IEN
SET ACHS(.03)=$$DOC^ACHS(2,7)
+6 SET ACHS(.04)="F"
SET ACHS(.06)=""
+7 ;ADD
+8 SET ACHS(.01)=ACHSICDN
+9 ;The first DX on the EOBR is the primary DX.
+10 SET ACHS(.05)=$SELECT(ACHSDX=1:"P",1:"S")
+11 DO DXA^BMCCHS(ACHS(.03),.ACHS)
+12 ;DEL
+13 SET ACHS(.01)=ACHSICDO
+14 DO DXD^BMCCHS(ACHS(.03),.ACHS)
+15 ; ACHS*3.1*23
KILL DIC,DLAYGO
+16 QUIT
+17 ; ----------------------------
GETREF(ACHS) ;EP - select ref, retrieve info
+1 IF '$$LINK
QUIT
GETREF0 WRITE !
+1 NEW DIC,D
+2 ; In DIC("S"), the Ref must be [C]HS and [A]ctive.
+3 SET DIC="^BMCREF("
SET DIC(0)="AEMQ"
SET DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
+4 IF $GET(ACHS)
IF $DATA(^BMCREF(ACHS))
DO SET^BMCCHS(ACHS,.ACHS)
SET DIC("B")=$PIECE($GET(^DPT(ACHS(.03),0)),U)
+5 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ ADD NXT SECT TO ALLOW SEL REF FOR DEN
GETREF1 ;
+1 DO ^DIC
+2 ;ACHS*3.1*23
IF $DATA(DUOUT)
QUIT
+3 IF $GET(ACHD("FAC"))'=""
DO GETREF3
+4 IF '$TEST
DO GETREF2
+5 ;ACHS*3.1*23
IF $DATA(DUOUT)
GOTO GETREF0
+6 ;ACHS*3.1*23
IF Y=1
IF $$GET1^DIQ(90001.31,DUZ(2),4104)="NO"
QUIT
+7 ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ REF NOT REQ IF W/IN 180 DAYS OF IMPLEMENTING RCIS
+8 ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ
IF Y<1
QUIT
+9 ;Q:(Y<1)!('$G(ACHS)) ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ
+10 DO GETREF4
+11 DO EN^XBVK("BMC")
+12 QUIT
GETREF2 ; TEST FOR ADDING NEW PO'S
+1 ;D ^DIC ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ CALLED ABOVE
+2 IF Y<1
Begin DoDot:1
+3 IF $DATA(DUOUT)!$DATA(DTOUT)!($GET(ACHS("ADD")))
QUIT
+4 NEW A,I,V
+5 ;S Y=$P($G(^BMCPARM(DUZ(2),0)),U,24);IHS/SET/GTH ACHS*3.1*5 12/06/2002
+6 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
SET Y=$$GET1^DIQ(90001.31,DUZ(2),.24,"I")
+7 IF Y
IF $$FMDIFF^XLFDT(DT,Y)<180
IF $$DIR^XBDIR("Y","Are you sure you want to enter a P.O. w/o a Referral","N","","","",1)
KILL ACHS,ACHSREF
QUIT
+8 ;ACHS*3.1*13 8.15.05 IHS/OIT/FCJ ADD NXT 2 LNS TO TST PAR REQ REF FOR PO
+9 SET Y=$$GET1^DIQ(90001.31,DUZ(2),4104)
+10 IF Y="NO"
IF $$DIR^XBDIR("Y","Are you sure you want to enter a P.O. w/o a Referral","N","","","",1)
KILL ACHS,ACHSREF
QUIT
+11 ;ACHS*3.1*23
IF $DATA(DUOUT)
QUIT
+12 WRITE *7,!!,"You must have a CHS referral to enter a P.O.",!!
+13 SET DUOUT=$$DIR^XBDIR("E","Press RETURN...")
End DoDot:1
QUIT
+14 QUIT
+15 ;
GETREF3 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ TST CALL FR DEN PKG ADDED NXT 3 LINES
+1 IF Y<1
Begin DoDot:1
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
QUIT
+3 WRITE *7,!!,"A Referral has not been entered.",!!
End DoDot:1
QUIT
+4 QUIT
+5 ;
GETREF4 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ ADD LN LABEL NXT SEC
+1 SET ACHS=+Y
+2 DO SET^BMCCHS(ACHS,.ACHS)
+3 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ ADDED TEST FOR DEN AND I DEN..
+4 ;I ($G(ACHS(.04))'="C")!($G(ACHS(.15))'="A") D G GETREF1 ;ACHS*3.1*10 4.19.04
+5 ;ACHS*3.1*22 IHS.OIT.FCJ ADDED TEST FOR APPROVED AND ALLOWING PO'S FOR CLOSED REF
+6 ;I $G(ACHD("FAC"))="",($G(ACHS(.04))'="C")!($G(ACHS(.15))'="A") D G GETREF1 ;ACHS*3.1*10 4.19.04
+7 ;.W !!," This must be a Referral that is 'ACTIVE/APPROVED' and 'CHS FACILITY'."
+8 ;.W !,"You have selected a Referral that is '",$$EXTSET^XBFUNC(90001,.15,$G(ACHS(.15))),"' and '",$$EXTSET^XBFUNC(90001,.04,$G(ACHS(.04))),"'.",!
+9 IF $GET(ACHD("FAC"))=""
IF $GET(ACHS(.04))'="C"
Begin DoDot:1
+10 WRITE !,"You have selected a Referral that is Not a CHS Referral."
+11 WRITE !,"Please select a CHS Referral",!
+12 SET ACHS=0
SET Y=0
KILL DA
End DoDot:1
GOTO GETREF1
+13 ;ACHS*3.1*22 END OF CHANGES
+14 ;ACHS*3.1*13 8.15.05 IHS/OIT/FCJ ADD NXT 2 LINES FOR DEN # TEST
+15 IF $GET(ACHD("FAC"))'=""
IF $GET(ACHSREF(1128))'=""
Begin DoDot:1
+16 WRITE !!," You have selected a Referral that already has a denial number, ",$GET(ACHS(1128)),!
End DoDot:1
+17 ;ACHS*3.1*23 ADD APPROVED FOR DENIAL TEST
+18 ;I $G(ACHD("FAC"))'="",($G(ACHS(.04))="I")!($G(ACHS(.04))="N")!($G(ACHS(.15))'="A") D G GETREF0
+19 IF $GET(ACHD("FAC"))'=""
IF ($GET(ACHS(.04))="I")!($GET(ACHS(.04))="N")!($GET(ACHS(.15))="X")!($GET(ACHS(.15))="C1")
Begin DoDot:1
+20 WRITE !!," This must be a Referral that is 'ACTIVE/APPROVED' and 'CHS FACILITY' or 'OTHER'."
+21 WRITE !,"You have selected a Referral that is '",$$EXTSET^XBFUNC(90001,.15,$GET(ACHS(.15))),"' and '",$$EXTSET^XBFUNC(90001,.04,$GET(ACHS(.04))),"'.",!
+22 SET ACHS=0
End DoDot:1
GOTO GETREF0
+23 ;ACHS*3.1*10 4.19.04 IHS/ITSC/FCJ END OF CHANGES
+24 ;ACHS*3.1*22 TEST FOR CLOSED REF CHCK TO CONTINUE
+25 IF $GET(ACHD("FAC"))=""
IF ($GET(ACHS(.15))="C1")!($GET(ACHS(.15))="X")
Begin DoDot:1
+26 WRITE !,"You have selected a 'CLOSED' Referral."
+27 SET DIR("A")="Do you wish to CONTINUE"
SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF +Y>0
SET Y=ACHS
QUIT
+28 SET ACHS=0
SET Y=0
KILL DA
End DoDot:1
IF Y=0
GOTO GETREF1
+29 SET DFN=ACHS(.03)
SET ACHSHRN=$$HRN^ACHS(DFN,DUZ(2))
+30 SET ACHSPROV=ACHS(.07)
+31 SET %=ACHS(.14)
+32 IF $LENGTH(%)
SET ACHSTYP=$SELECT(%="I":1,%="O":3,1:"")
+33 ;ACHS*3.1*10 4.21.04 IHS/ITSC/FCJ CHG THE EDOS AND ADDED NXT 3 LINES
+34 ;I $G(ACHS(1105)) S ACHSEDOS=ACHS(1105) ;ACHS*3.1*10 4.21.04
+35 ;ACHS*3.1*10 4.21.04
SET ACHSEDOS=$SELECT($GET(ACHS(1106)):ACHS(1106),$GET(ACHS(1105)):ACHS(1105),1:"")
+36 ;ACHS*3.1*11 8.24.04
SET ACHSDES=$EXTRACT($GET(ACHSREF(1201)),1,30)
+37 ;ACHS*3.1*10 4.21.04
SET ACHSRMPC=$SELECT($GET(ACHS(.32))=1:"I",$GET(ACHS(.32))=2:"II",$GET(ACHS(.32))=3:"III",$GET(ACHS(.32))=4:"IV",1:"")
+38 ;ACHS*3.1*10 4.21.04
SET ACHSESDO=$GET(ACHS(1101))
+39 QUIT
+40 ; ----------------------------
LINK() ;EP - Is link to RCIS on?
+1 ;Q +$P($G(^BMCPARM(DUZ(2),0)),U,4);IHS/SET/GTH ACHS*3.1*5 12/06/2002
+2 ;IHS/SET/GTH ACHS*3.1*5 12/06/2002
QUIT $$GET1^DIQ(90001.31,DUZ(2),.04,"I")
+3 ; ----------------------------
VCHK() ;EP - VER OF RCIS
+1 ;ACHS*3.1*11 8.24.04 IHS/ITSC/FCJ
QUIT $$VERSION^XPDUTL("BMC")
+2 ;
P(I,S,P) ;EP - Return Internal format of Referral with IEN of I,S, Piece P.
+1 ; FOR USE DURING DEVELOPMENT. RCIS WILL PROVIDE REQUIRED DATA ITEMS
+2 QUIT $PIECE($GET(^BMCREF(I,S)),U,P)
+3 ;
+4 ; ----------------------------
PX ;EP - Transfer PX info to RCIS.
+1 ; ACHSDIEN = P.O. IEN at the "D" level
+2 ;
+3 IF '$$LINK
QUIT
+4 NEW ACHS,ACHSPX,ACHSPX1
+5 ; Patient DFN
SET ACHS(.02)=$$DOC^ACHS(0,22)
+6 ; Referral IEN
SET ACHS(.03)=$$DOC^ACHS(2,7)
+7 SET ACHS(.04)="F"
+8 SET ACHS(.06)=""
+9 SET ACHSPX=0
+10 FOR
SET ACHSPX=$ORDER(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX))
IF '(ACHSPX=+ACHSPX)
QUIT
Begin DoDot:1
+11 SET ACHS(.01)=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX,0)),U)
+12 IF '(ACHS(.01)["ICPT(")
QUIT
+13 SET ACHS(.01)=+ACHS(.01)
+14 ; The first PX on the EOBR is the primary PX.
+15 IF $GET(ACHSPX1)
SET ACHS(.05)="S"
+16 IF '$TEST
SET ACHS(.05)="P"
SET ACHSPX1=1
+17 SET ACHS(.07)=$PIECE($GET(^ACHSF(DUZ(2),"D",ACHSDIEN,11,ACHSPX,0)),U,4)
+18 DO PXA^BMCCHS(ACHS(.03),.ACHS)
End DoDot:1
+19 QUIT
+20 ; ----------------------------
+21 ;ACHS*3.1*13 8.30.06 IHS/OIT/FCJ ADDED APPEAL SECT
APPEAL ;EP -Update Referral appeal info
+1 IF '$$LINK
QUIT
+2 ;APPEAL DT
SET ACHS(6116)=$PIECE(ACHSREC,U)
+3 ;APPEAL RESOLVE DT
SET ACHS(6117)=$PIECE(ACHSREC,U,4)
+4 ;APPEAL STATUS
SET ACHS(6118)=$PIECE(ACHSREC,U,2)
+5 ;APPEAL LEVEL
SET ACHS(6119)=$PIECE(ACHSREC,U,3)
+6 SET I=$PIECE(^ACHSDENA(ACHS(6118),0),U)
+7 SET ACHS(1112)=$SELECT(I="PAYED WITH ADDITIONAL MONEY":"A",I="APPEAL PENDING":"PA",I="REVERSED AFTER APPEAL":"A",I="UPHELD AFTER APPEAL":"D",1:"")
+8 ;APPROVAL/DENIAL DT
SET ACHS(1113)=DT
+9 ;CHS STAFF
SET ACHS(1121)=DUZ
+10 ;Dt of denial
SET ACHS(1122)=DT
+11 ; denial NUMBER
SET ACHS(1128)=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,0),U)
+12 KILL S
+13 IF $$PATCH^XPDUTL("BMC*4.0*3")
DO APPEAL^BMCCHS1(.ACHS)
+14 QUIT
+15 ;
STAT(S) ;EP - Update Referral status
+1 ; ACHSREF must contain the Referral IEN.
+2 IF '$$LINK
QUIT
+3 NEW ACHS
+4 SET ACHS(1112)=S
+5 SET ACHS(1113)=DT
+6 ;
+7 IF S="D"
Begin DoDot:1
+8 ;PRIM PROV
IF $PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,100),U)="Y"
SET ACHS(.07)=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,100),U,2)
+9 ;INPAT/OUT
SET ACHS(.14)=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,100),U,10)
+10 SET ACHS(.15)=$SELECT(ACHS(.14)="O":"C1",1:"A")
+11 ;DT OF SERVICE
SET ACHS(1106)=ACHDDOS
+12 ;APPROVAL/DENIAL DATE
SET ACHS(1113)=DT
+13 ; denial reason.
SET ACHS(1114)=ACHSREF(1114)
+14 ; CHS STAFF
SET ACHS(1121)=DUZ
+15 ; Dt of denial
SET ACHS(1122)=DT
+16 ; denial NUMBER
SET ACHS(1128)=ACHDNUM
+17 ;ACHS*3.1*11 9.27.04 IHS/ITSC/FCJ ADDED NXT SEC MULT DEN REASON/PROV
+18 ;ACHS(200...) PROV ;ACHS(300...) REASON
+19 FOR X=200,300
IF $DATA(^ACHSDEN(DUZ(2),"D",ACHSA,X))
Begin DoDot:2
+20 SET CT=0
SET X1=0
+21 SET CT=$SELECT(X=200:4401,X=300:4301,1:"")
+22 FOR
SET X1=$ORDER(^ACHSDEN(DUZ(2),"D",ACHSA,X,X1))
IF X1'?1N.N
QUIT
Begin DoDot:3
+23 SET ACHS(CT)=$PIECE(^ACHSDEN(DUZ(2),"D",ACHSA,X,X1,0),U)
+24 SET CT=CT+1
End DoDot:3
End DoDot:2
+25 KILL X,X1,CT
+26 ;ACHS*3.1*11 9.27.04 IHS/ITSC/FCJ END OF CHG
End DoDot:1
+27 KILL S
+28 DO STAT^BMCCHS(ACHSREF,"P",.ACHS)
+29 QUIT
+30 ; ----------------------------
