ACHSBMC.m

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