BMCCHS ; IHS/OIT/FCJ - CHS INTERFACE RTN 1 OF 2 ; [ 09/22/2006 10:03 AM ]
;;4.0;REFERRED CARE INFO SYSTEM;**2,8**;JAN 09, 2006;Build 101
;
;IHS/ITSC/FCJ Added entries for link to CHS denial documents,
; also added other entries for CHS PO entry
; field: 32,1106,1107,1108,1201,1101,1128
; ADD MULT DENIAL PRV AND MULT DENIAL REASONS
;4.0 IHS/OIT/FCJ TEST FOR CLOSE AND REQUIRE PO PARAMETER
;4.0*2* 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1 FOR CPT/ICD CODES
;4.0*8 7.20.12 IHS.OIT.FCJ ADDED DENIAL OPTIONS
;4.0*8 7.22.13 IHS.OIT.FCJ ADDED SNOMED CLOSE TERM
;
W:'$D(ZTQUEUED) !!,"NO ENTRY FROM THE TOP OF ^BMCCHS",!!
Q
;
;----------
SET(BMCRIEN,BMCCHS) ;EP - SET BMCCHS ARRAY FOR CHS PACKAGE
; d set^bmcchs(referral_ien,.array_name)
; BMCRIEN is the IEN of the RCIS REFERRAL
; BMCCHS is array into which values are set
;
NEW BMCCHSX
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
;BMC*4.0*8 ADDED 6120 TO NXT LINE
F BMCCHSX=.01,.02,.03,.04,.05,.06,.07,.08,.09,.11,.13,.14,.15,.32,1101,1105,1106,1107,1108,1112,1113,1114,1128,1201,6120 D
.S BMCCHS(BMCCHSX)=$$VALI^XBDIQ1(90001,BMCRIEN,BMCCHSX)
F BMCCHSX=1105,1106 D
.S BMCCHS(BMCCHSX)=$P(BMCCHS(BMCCHSX),".")
Q
;----------
STAT(BMCRIEN,F,BMCCHS) ;EP - CHS STATUS INFORMATION
; d stat^bmcchs(referral_ien,"G",.array_name)
; or
; s array(.07)=prim denial prov
; s array(.15)=closed
; s array(1112)=chs approval status
; s array(1113)=chs approval/denial date
; s array(1114)=chs prim denial reason
; s array(6120)=chs denial reason option
; s array(1128)=chs denial number
; s array(1106)=chs dos
; s array(4301...)=mult denial prov
; s array(4401...)=mult denial reasons
; d stat^bmcchs(referral_ien,"P",.array_name)
;
; BMCRIEN is the IEN of the RCIS REFERRAL
; BMCCHS is array into which values are set
; F is a flag: G to get values, P to put values in file
;
NEW BMCCHSX
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
D @("STAT"_F)
I $G(BMCCHS(1128))'="" D DENIAL
Q
;
STATG ; GET CHS STATUS INFORMATION
;BMC*4.0*8 ADDED 6120 TO NXT LINE
F BMCCHSX=1112,1113,1114,6120 S BMCCHS(BMCCHSX)=$$VALI^XBDIQ1(90001,BMCRIEN,BMCCHSX)
Q
;
STATP ; SET CHS STATUS INFORMATION
S DIE="^BMCREF(",DA=BMCRIEN,DR=""
;BMC*4.0*8 ADDED 6120 TO NXT LINE
F BMCCHSX=1112,1113,1114,6120 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
Q:DR=""
D DIE^BMCFMC
S DIE="^BMCREF(",DA=BMCRIEN,DR=""
I $G(BMCCHS(1128))'="" D
.;4.0 IHS/OIT/FCJ CHG NXT SECTION TO TEST FOR PARAMETER
.;F BMCCHSX=.07,.15,1106,1128 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
.F BMCCHSX=.07,.14,1106,1128 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
.I $P($G(^BMCPARM(DUZ(2),4100)),U,3)="Y" D
..S BMCCHSX=.15
..S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
.Q:DR=""
.D DIE^BMCFMC
Q
;----------
AUTH(BMCRIEN,BMCAIEN,F,BMCCHS) ;EP - CHS AUTHORIZATIONS MULTIPLE
; d auth^bmcchs(referral_ien,authorization_ien,"G",.array_name)
; or
; s array(.02)=dollar value
; d auth^bmcchs(referral_ien,authorization_ien,"P",.array_name)
; or
; d auth^bmcchs(referral_ien,authorization_ien,"D")
;
; BMCRIEN is the referral ien
; BMCAIEN is the CHS AUTHORIZATION ien
; BMCCHS is the variable array root
; F is a flag: G to get values, P to put values in file, D to
; delete entries
;
NEW BMCCHSV,BMCCHSX
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
Q:'$G(BMCAIEN)
D @("AUTH"_F)
SNOCLS ;BMC*4.0*8 7.22.13 IHS.OIT.FCJ ADD SNOMED CODE
I $P(^BMCREF(BMCRIEN,0),U,15)="C1" D SNOCLS^BMCCLO
Q
;
AUTHG ; GET CHS AUTHORIZATION VALUES
Q:'$D(^BMCREF(BMCRIEN,41,BMCAIEN,0))
F BMCCHSX=.02,.03,.04,.05,.06,.07,.08,.09,.13 S BMCCHS(BMCCHSX)=""
S DIC=90001,DR=4100,DR(90001.41)=".02;.03;.04;.05;.06;.07;.08;.09;.13",DA(90001.41)=BMCAIEN,DA=BMCRIEN,DIQ="BMCCHSV",DIQ(0)="I"
D DIQ1^BMCFMC
F BMCCHSX=.02,.03,.04,.05,.06,.07,.08,.09,.13 S BMCCHS(BMCCHSX)=$G(BMCCHSV(90001.41,BMCAIEN,BMCCHSX,"I"))
Q
;
AUTHP ; SET CHS AUTHORIZATION VALUES INTO FILE
I '$D(^BMCREF(BMCRIEN,41,BMCAIEN,0)) D AUTHPADD Q
D AUTHPMOD
Q
;
AUTHPADD ; ADD NEW CHS AUTHORIZATION
S DIC("DR")=""
F BMCCHSX=.02,.03,.04,.05,.06,.07,.08 S:$G(BMCCHS(BMCCHSX))'="" DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
I $G(BMCCHS(.09))'="" S DIC("DR")=DIC("DR")_";.09////"_BMCCHS(.09)
I $G(BMCCHS(.13))'="" S DIC("DR")=DIC("DR")_";.13////"_BMCCHS(.13)
S DIC="^BMCREF("_BMCRIEN_",41,",DIC(0)="L",DA(1)=BMCRIEN,DIC("P")=$P(^DD(90001,4100,0),U,2),X=BMCAIEN,DINUM=BMCAIEN
D FILE^BMCFMC
Q
AUTHPMOD ; MODIFY EXISTING CHS AUTHORIZATION
S DR=""
F BMCCHSX=.02,.03,.04,.05,.06,.07,.08 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
I $G(BMCCHS(.09))'="" S DR=DR_";.09////"_BMCCHS(.09)
I $G(BMCCHS(.13))'="" S DR=DR_";.13////"_BMCCHS(.13)
S DIE="^BMCREF("_BMCRIEN_",41,",DA(1)=BMCRIEN,DA=BMCAIEN
D DIE^BMCFMC
Q
;
AUTHD ; DELETE CHS AUTHORIZATION ENTRY
Q:'$D(^BMCREF(BMCRIEN,41,BMCAIEN,0))
S DIK="^BMCREF("_BMCRIEN_",41,",DA=BMCAIEN,DA(1)=BMCRIEN
D DIK^BMCFMC
Q
;---------
;IHS/ITSC/FCJ ADDED NXT SECTION
DENIAL ;TEST AND ADD MULT DENIAL PROVIDERS AND MULT DENIAL REASONS
S BMCCHSX=4300,BMCCHSP=0,BMCCHSR=0,DIC("DR")=""
F S BMCCHSX=$O(BMCCHS(BMCCHSX)) Q:(BMCCHSX>4499)!(BMCCHSX'?1N.N) D
.;Q:BMCCHS(BMCCHSX)="" S X="`"_BMCCHS(BMCCHSX) ;BMC*4.0*8
.Q:BMCCHS(BMCCHSX)="" S X="`"_+BMCCHS(BMCCHSX) ;BMC*4.0*8
.I BMCCHSX>4400 D
..S BMCCHSP=BMCCHSP+1
..S DIC="^BMCREF("_BMCRIEN_",44,",DIC(0)="L",DLAYGO=90001
..S DA(1)=BMCRIEN
..I '$D(^BMCREF(BMCRIEN,44,0)) S ^BMCREF(BMCRIEN,44,0)="^90001.44PA^0^0"
..D ^DIC
..K DIE,DIC,DA,X,Y,DLAYGO
.E I BMCCHSX<4400 D
..S BMCCHSR=BMCCHSR+1
..;BMC*4.0*8 ADDED DIE TO NEXT LINE
..S (DIE,DIC)="^BMCREF("_BMCRIEN_",43,",DIC(0)="L",DLAYGO=90001
..S DA(1)=BMCRIEN
..I '$D(^BMCREF(BMCRIEN,43,0)) S ^BMCREF(BMCRIEN,43,0)="^90001.43PA^0^0"
..D ^DIC
..;S DR=".02///"_$P(BMCCHS(BMCCHSX),U,2) ;BMC*4.0*8
..;D ^DIE ;BMC*4.0*8
..K DIE,DIC,DA,X,Y,DLAYGO
K DIE,DIC,DA,X,Y,DLAYGO
Q
;---------
DXA(BMCRIEN,BMCCHS) ;EP - ADD DIAGNOSIS
; s array(.01)=ICD9 ien
; s array(.02-.06) to appropriate internal values
; d dxa^bmcchs(referral_ien,.array_name)
;
NEW BMCCHSQ,BMCCHSX,BMCCHSY
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
S BMCCHS(.03)=BMCRIEN
S BMCCHSQ=0
F BMCCHSX=.01,.02,.03,.04,.05 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
Q:BMCCHS(.01)=-1 ;BMC 4.0*2 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1
Q:BMCCHSQ
S BMCCHSX=BMCCHS(.01),BMCCHSY=0
; check for duplicate icd9 codes for same TYPE (provisional or final)
F S BMCCHSY=$O(^BMCDX("AD",BMCRIEN,BMCCHSY)) Q:'BMCCHSY I $P(^BMCDX(BMCCHSY,0),U)=BMCCHSX,$P(^(0),U,4)=BMCCHS(.04) S BMCCHSQ=1 Q
I BMCCHSQ D Q ; dupe so increment COUNT field
. S BMCCHSX=$$VALI^XBDIQ1(90001.01,BMCCHSY,.07)
. S BMCCHSX=BMCCHSX+1
. S DR=".07////"_BMCCHSX,DIE="^BMCDX(",DA=BMCCHSY
. D DIE^BMCFMC
S DIC("DR")=""
F BMCCHSX=.02,.03,.04,.05,.06 S:$G(BMCCHS(BMCCHSX))'="" DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
S DIC("DR")=DIC("DR")_";.07////1"
S DIC="^BMCDX(",DIC(0)="L",DLAYGO=90001.01,X=BMCCHS(.01)
D FILE^BMCFMC
Q
;---------
DXD(BMCRIEN,BMCCHS) ;EP - DELETE DIAGNOSIS
; s array(.01)=ICD9 ien
; s array(.04)=P or F
; d dxd^bmcchs(referral_ien,.array_name)
;
NEW BMCCHSQ,BMCCHSX,BMCCHSY
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
S BMCCHSQ=0
F BMCCHSX=.01,.04 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
Q:BMCCHSQ
S BMCCHSX=BMCCHS(.01),BMCCHSY=0
; find icd9 code for same TYPE (provisional or final)
F S BMCCHSY=$O(^BMCDX("AD",BMCRIEN,BMCCHSY)) Q:'BMCCHSY I $P(^BMCDX(BMCCHSY,0),U)=BMCCHSX,$P(^(0),U,4)=BMCCHS(.04) S BMCCHSQ=1 Q
I BMCCHSQ D Q ; found it so decrement COUNT field and delete if 0
. S BMCCHSX=$$VALI^XBDIQ1(90001.01,BMCCHSY,.07)
. S BMCCHSX=BMCCHSX-1
. I BMCCHSX=0 S DIK="^BMCDX(",DA=BMCCHSY D ^DIK Q ; delete entry
.; if count>0 update count and leave entry
. S DR=".07////"_BMCCHSX,DIE="^BMCDX(",DA=BMCCHSY
. D DIE^BMCFMC
Q
;---------
PXA(BMCRIEN,BMCCHS) ;EP - ADD PROCEDURE
; s array(.01)=CPT code ien
; s array(.02-.07) to appropriate internal values
; d px^bmcchs(referral_ien,.array_name)
;
NEW BMCCHSQ,BMCCHSX,BMCCHSY
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
S BMCCHS(.03)=BMCRIEN
S BMCCHSQ=0
F BMCCHSX=.01,.02,.03,.04,.05,.07 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
Q:BMCCHSQ
Q:BMCCHS(.01)=-1 ;BMC 4.0*2* 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1
S BMCCHSX=BMCCHS(.01),BMCCHSY=0
; check for duplicate cpt codes for same TYPE (provisional or final)
F S BMCCHSY=$O(^BMCPX("AD",BMCRIEN,BMCCHSY)) Q:'BMCCHSY I $P(^BMCPX(BMCCHSY,0),U)=BMCCHSX,$P(^(0),U,4)=BMCCHS(.04) S BMCCHSQ=1 Q
I BMCCHSQ D Q ; dupe so increment UNITS field
. S BMCCHSX=$G(BMCCHS(.07))
. Q:BMCCHSX=""
. S BMCCHSX=BMCCHSX+$$VALI^XBDIQ1(90001.02,BMCCHSY,.07)
. S DR=".07////"_BMCCHSX,DIE="^BMCPX(",DA=BMCCHSY
. D DIE^BMCFMC
S DIC("DR")=""
F BMCCHSX=.02,.03,.04,.05,.06,.07 S:$G(BMCCHS(BMCCHSX))'="" DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
S DIC="^BMCPX(",DIC(0)="L",DLAYGO=90001.02,X=BMCCHS(.01)
D FILE^BMCFMC
Q
;---------
PXD(BMCRIEN,BMCCHS) ;EP - DELETE PROCEDURE
; s array(.01)=CPT ien
; s array(.04)=P or F
; s array(.07)=number of units
; d dxd^bmcchs(referral_ien,.array_name)
;
NEW BMCCHSQ,BMCCHSX,BMCCHSY
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
S BMCCHSQ=0
F BMCCHSX=.01,.04,.07 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
Q:BMCCHSQ
S BMCCHSX=BMCCHS(.01),BMCCHSY=0
; find cpt code for same TYPE (provisional or final)
F S BMCCHSY=$O(^BMCPX("AD",BMCRIEN,BMCCHSY)) Q:'BMCCHSY I $P(^BMCPX(BMCCHSY,0),U)=BMCCHSX,$P(^(0),U,4)=BMCCHS(.04) S BMCCHSQ=1 Q
I BMCCHSQ D Q ; found it so decrement UNITS field and delete if 0
. S BMCCHSX=$$VALI^XBDIQ1(90001.02,BMCCHSY,.07)
. S BMCCHSX=BMCCHSX-BMCCHS(.07)
. I BMCCHSX<1 S DIK="^BMCPX(",DA=BMCCHSY D ^DIK Q ; delete entry
.; if units>0 update units and leave entry
. S DR=".07////"_BMCCHSX,DIE="^BMCPX(",DA=BMCCHSY
. D DIE^BMCFMC
Q
BMCCHS ; IHS/OIT/FCJ - CHS INTERFACE RTN 1 OF 2 ; [ 09/22/2006 10:03 AM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**2,8**;JAN 09, 2006;Build 101
+2 ;
+3 ;IHS/ITSC/FCJ Added entries for link to CHS denial documents,
+4 ; also added other entries for CHS PO entry
+5 ; field: 32,1106,1107,1108,1201,1101,1128
+6 ; ADD MULT DENIAL PRV AND MULT DENIAL REASONS
+7 ;4.0 IHS/OIT/FCJ TEST FOR CLOSE AND REQUIRE PO PARAMETER
+8 ;4.0*2* 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1 FOR CPT/ICD CODES
+9 ;4.0*8 7.20.12 IHS.OIT.FCJ ADDED DENIAL OPTIONS
+10 ;4.0*8 7.22.13 IHS.OIT.FCJ ADDED SNOMED CLOSE TERM
+11 ;
+12 IF '$DATA(ZTQUEUED)
WRITE !!,"NO ENTRY FROM THE TOP OF ^BMCCHS",!!
+13 QUIT
+14 ;
+15 ;----------
SET(BMCRIEN,BMCCHS) ;EP - SET BMCCHS ARRAY FOR CHS PACKAGE
+1 ; d set^bmcchs(referral_ien,.array_name)
+2 ; BMCRIEN is the IEN of the RCIS REFERRAL
+3 ; BMCCHS is array into which values are set
+4 ;
+5 NEW BMCCHSX
+6 IF '$GET(BMCRIEN)
QUIT
+7 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+8 ;BMC*4.0*8 ADDED 6120 TO NXT LINE
+9 FOR BMCCHSX=.01,.02,.03,.04,.05,.06,.07,.08,.09,.11,.13,.14,.15,.32,1101,1105,1106,1107,1108,1112,1113,1114,1128,1201,6120
Begin DoDot:1
+10 SET BMCCHS(BMCCHSX)=$$VALI^XBDIQ1(90001,BMCRIEN,BMCCHSX)
End DoDot:1
+11 FOR BMCCHSX=1105,1106
Begin DoDot:1
+12 SET BMCCHS(BMCCHSX)=$PIECE(BMCCHS(BMCCHSX),".")
End DoDot:1
+13 QUIT
+14 ;----------
STAT(BMCRIEN,F,BMCCHS) ;EP - CHS STATUS INFORMATION
+1 ; d stat^bmcchs(referral_ien,"G",.array_name)
+2 ; or
+3 ; s array(.07)=prim denial prov
+4 ; s array(.15)=closed
+5 ; s array(1112)=chs approval status
+6 ; s array(1113)=chs approval/denial date
+7 ; s array(1114)=chs prim denial reason
+8 ; s array(6120)=chs denial reason option
+9 ; s array(1128)=chs denial number
+10 ; s array(1106)=chs dos
+11 ; s array(4301...)=mult denial prov
+12 ; s array(4401...)=mult denial reasons
+13 ; d stat^bmcchs(referral_ien,"P",.array_name)
+14 ;
+15 ; BMCRIEN is the IEN of the RCIS REFERRAL
+16 ; BMCCHS is array into which values are set
+17 ; F is a flag: G to get values, P to put values in file
+18 ;
+19 NEW BMCCHSX
+20 IF '$GET(BMCRIEN)
QUIT
+21 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+22 DO @("STAT"_F)
+23 IF $GET(BMCCHS(1128))'=""
DO DENIAL
+24 QUIT
+25 ;
STATG ; GET CHS STATUS INFORMATION
+1 ;BMC*4.0*8 ADDED 6120 TO NXT LINE
+2 FOR BMCCHSX=1112,1113,1114,6120
SET BMCCHS(BMCCHSX)=$$VALI^XBDIQ1(90001,BMCRIEN,BMCCHSX)
+3 QUIT
+4 ;
STATP ; SET CHS STATUS INFORMATION
+1 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR=""
+2 ;BMC*4.0*8 ADDED 6120 TO NXT LINE
+3 FOR BMCCHSX=1112,1113,1114,6120
IF $GET(BMCCHS(BMCCHSX))'=""
SET DR=DR_$SELECT(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
+4 IF DR=""
QUIT
+5 DO DIE^BMCFMC
+6 SET DIE="^BMCREF("
SET DA=BMCRIEN
SET DR=""
+7 IF $GET(BMCCHS(1128))'=""
Begin DoDot:1
+8 ;4.0 IHS/OIT/FCJ CHG NXT SECTION TO TEST FOR PARAMETER
+9 ;F BMCCHSX=.07,.15,1106,1128 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
+10 FOR BMCCHSX=.07,.14,1106,1128
IF $GET(BMCCHS(BMCCHSX))'=""
SET DR=DR_$SELECT(DR="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
+11 IF $PIECE($GET(^BMCPARM(DUZ(2),4100)),U,3)="Y"
Begin DoDot:2
+12 SET BMCCHSX=.15
+13 IF $GET(BMCCHS(BMCCHSX))'=""
SET DR=DR_$SELECT(DR="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
End DoDot:2
+14 IF DR=""
QUIT
+15 DO DIE^BMCFMC
End DoDot:1
+16 QUIT
+17 ;----------
AUTH(BMCRIEN,BMCAIEN,F,BMCCHS) ;EP - CHS AUTHORIZATIONS MULTIPLE
+1 ; d auth^bmcchs(referral_ien,authorization_ien,"G",.array_name)
+2 ; or
+3 ; s array(.02)=dollar value
+4 ; d auth^bmcchs(referral_ien,authorization_ien,"P",.array_name)
+5 ; or
+6 ; d auth^bmcchs(referral_ien,authorization_ien,"D")
+7 ;
+8 ; BMCRIEN is the referral ien
+9 ; BMCAIEN is the CHS AUTHORIZATION ien
+10 ; BMCCHS is the variable array root
+11 ; F is a flag: G to get values, P to put values in file, D to
+12 ; delete entries
+13 ;
+14 NEW BMCCHSV,BMCCHSX
+15 IF '$GET(BMCRIEN)
QUIT
+16 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+17 IF '$GET(BMCAIEN)
QUIT
+18 DO @("AUTH"_F)
SNOCLS ;BMC*4.0*8 7.22.13 IHS.OIT.FCJ ADD SNOMED CODE
+1 IF $PIECE(^BMCREF(BMCRIEN,0),U,15)="C1"
DO SNOCLS^BMCCLO
+2 QUIT
+3 ;
AUTHG ; GET CHS AUTHORIZATION VALUES
+1 IF '$DATA(^BMCREF(BMCRIEN,41,BMCAIEN,0))
QUIT
+2 FOR BMCCHSX=.02,.03,.04,.05,.06,.07,.08,.09,.13
SET BMCCHS(BMCCHSX)=""
+3 SET DIC=90001
SET DR=4100
SET DR(90001.41)=".02;.03;.04;.05;.06;.07;.08;.09;.13"
SET DA(90001.41)=BMCAIEN
SET DA=BMCRIEN
SET DIQ="BMCCHSV"
SET DIQ(0)="I"
+4 DO DIQ1^BMCFMC
+5 FOR BMCCHSX=.02,.03,.04,.05,.06,.07,.08,.09,.13
SET BMCCHS(BMCCHSX)=$GET(BMCCHSV(90001.41,BMCAIEN,BMCCHSX,"I"))
+6 QUIT
+7 ;
AUTHP ; SET CHS AUTHORIZATION VALUES INTO FILE
+1 IF '$DATA(^BMCREF(BMCRIEN,41,BMCAIEN,0))
DO AUTHPADD
QUIT
+2 DO AUTHPMOD
+3 QUIT
+4 ;
AUTHPADD ; ADD NEW CHS AUTHORIZATION
+1 SET DIC("DR")=""
+2 FOR BMCCHSX=.02,.03,.04,.05,.06,.07,.08
IF $GET(BMCCHS(BMCCHSX))'=""
SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
+3 IF $GET(BMCCHS(.09))'=""
SET DIC("DR")=DIC("DR")_";.09////"_BMCCHS(.09)
+4 IF $GET(BMCCHS(.13))'=""
SET DIC("DR")=DIC("DR")_";.13////"_BMCCHS(.13)
+5 SET DIC="^BMCREF("_BMCRIEN_",41,"
SET DIC(0)="L"
SET DA(1)=BMCRIEN
SET DIC("P")=$PIECE(^DD(90001,4100,0),U,2)
SET X=BMCAIEN
SET DINUM=BMCAIEN
+6 DO FILE^BMCFMC
+7 QUIT
AUTHPMOD ; MODIFY EXISTING CHS AUTHORIZATION
+1 SET DR=""
+2 FOR BMCCHSX=.02,.03,.04,.05,.06,.07,.08
IF $GET(BMCCHS(BMCCHSX))'=""
SET DR=DR_$SELECT(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
+3 IF $GET(BMCCHS(.09))'=""
SET DR=DR_";.09////"_BMCCHS(.09)
+4 IF $GET(BMCCHS(.13))'=""
SET DR=DR_";.13////"_BMCCHS(.13)
+5 SET DIE="^BMCREF("_BMCRIEN_",41,"
SET DA(1)=BMCRIEN
SET DA=BMCAIEN
+6 DO DIE^BMCFMC
+7 QUIT
+8 ;
AUTHD ; DELETE CHS AUTHORIZATION ENTRY
+1 IF '$DATA(^BMCREF(BMCRIEN,41,BMCAIEN,0))
QUIT
+2 SET DIK="^BMCREF("_BMCRIEN_",41,"
SET DA=BMCAIEN
SET DA(1)=BMCRIEN
+3 DO DIK^BMCFMC
+4 QUIT
+5 ;---------
+6 ;IHS/ITSC/FCJ ADDED NXT SECTION
DENIAL ;TEST AND ADD MULT DENIAL PROVIDERS AND MULT DENIAL REASONS
+1 SET BMCCHSX=4300
SET BMCCHSP=0
SET BMCCHSR=0
SET DIC("DR")=""
+2 FOR
SET BMCCHSX=$ORDER(BMCCHS(BMCCHSX))
IF (BMCCHSX>4499)!(BMCCHSX'?1N.N)
QUIT
Begin DoDot:1
+3 ;Q:BMCCHS(BMCCHSX)="" S X="`"_BMCCHS(BMCCHSX) ;BMC*4.0*8
+4 ;BMC*4.0*8
IF BMCCHS(BMCCHSX)=""
QUIT
SET X="`"_+BMCCHS(BMCCHSX)
+5 IF BMCCHSX>4400
Begin DoDot:2
+6 SET BMCCHSP=BMCCHSP+1
+7 SET DIC="^BMCREF("_BMCRIEN_",44,"
SET DIC(0)="L"
SET DLAYGO=90001
+8 SET DA(1)=BMCRIEN
+9 IF '$DATA(^BMCREF(BMCRIEN,44,0))
SET ^BMCREF(BMCRIEN,44,0)="^90001.44PA^0^0"
+10 DO ^DIC
+11 KILL DIE,DIC,DA,X,Y,DLAYGO
End DoDot:2
+12 IF '$TEST
IF BMCCHSX<4400
Begin DoDot:2
+13 SET BMCCHSR=BMCCHSR+1
+14 ;BMC*4.0*8 ADDED DIE TO NEXT LINE
+15 SET (DIE,DIC)="^BMCREF("_BMCRIEN_",43,"
SET DIC(0)="L"
SET DLAYGO=90001
+16 SET DA(1)=BMCRIEN
+17 IF '$DATA(^BMCREF(BMCRIEN,43,0))
SET ^BMCREF(BMCRIEN,43,0)="^90001.43PA^0^0"
+18 DO ^DIC
+19 ;S DR=".02///"_$P(BMCCHS(BMCCHSX),U,2) ;BMC*4.0*8
+20 ;D ^DIE ;BMC*4.0*8
+21 KILL DIE,DIC,DA,X,Y,DLAYGO
End DoDot:2
End DoDot:1
+22 KILL DIE,DIC,DA,X,Y,DLAYGO
+23 QUIT
+24 ;---------
DXA(BMCRIEN,BMCCHS) ;EP - ADD DIAGNOSIS
+1 ; s array(.01)=ICD9 ien
+2 ; s array(.02-.06) to appropriate internal values
+3 ; d dxa^bmcchs(referral_ien,.array_name)
+4 ;
+5 NEW BMCCHSQ,BMCCHSX,BMCCHSY
+6 IF '$GET(BMCRIEN)
QUIT
+7 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+8 SET BMCCHS(.03)=BMCRIEN
+9 SET BMCCHSQ=0
+10 FOR BMCCHSX=.01,.02,.03,.04,.05
IF $GET(BMCCHS(BMCCHSX))=""
SET BMCCHSQ=1
+11 ;BMC 4.0*2 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1
IF BMCCHS(.01)=-1
QUIT
+12 IF BMCCHSQ
QUIT
+13 SET BMCCHSX=BMCCHS(.01)
SET BMCCHSY=0
+14 ; check for duplicate icd9 codes for same TYPE (provisional or final)
+15 FOR
SET BMCCHSY=$ORDER(^BMCDX("AD",BMCRIEN,BMCCHSY))
IF 'BMCCHSY
QUIT
IF $PIECE(^BMCDX(BMCCHSY,0),U)=BMCCHSX
IF $PIECE(^(0),U,4)=BMCCHS(.04)
SET BMCCHSQ=1
QUIT
+16 ; dupe so increment COUNT field
IF BMCCHSQ
Begin DoDot:1
+17 SET BMCCHSX=$$VALI^XBDIQ1(90001.01,BMCCHSY,.07)
+18 SET BMCCHSX=BMCCHSX+1
+19 SET DR=".07////"_BMCCHSX
SET DIE="^BMCDX("
SET DA=BMCCHSY
+20 DO DIE^BMCFMC
End DoDot:1
QUIT
+21 SET DIC("DR")=""
+22 FOR BMCCHSX=.02,.03,.04,.05,.06
IF $GET(BMCCHS(BMCCHSX))'=""
SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
+23 SET DIC("DR")=DIC("DR")_";.07////1"
+24 SET DIC="^BMCDX("
SET DIC(0)="L"
SET DLAYGO=90001.01
SET X=BMCCHS(.01)
+25 DO FILE^BMCFMC
+26 QUIT
+27 ;---------
DXD(BMCRIEN,BMCCHS) ;EP - DELETE DIAGNOSIS
+1 ; s array(.01)=ICD9 ien
+2 ; s array(.04)=P or F
+3 ; d dxd^bmcchs(referral_ien,.array_name)
+4 ;
+5 NEW BMCCHSQ,BMCCHSX,BMCCHSY
+6 IF '$GET(BMCRIEN)
QUIT
+7 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+8 SET BMCCHSQ=0
+9 FOR BMCCHSX=.01,.04
IF $GET(BMCCHS(BMCCHSX))=""
SET BMCCHSQ=1
+10 IF BMCCHSQ
QUIT
+11 SET BMCCHSX=BMCCHS(.01)
SET BMCCHSY=0
+12 ; find icd9 code for same TYPE (provisional or final)
+13 FOR
SET BMCCHSY=$ORDER(^BMCDX("AD",BMCRIEN,BMCCHSY))
IF 'BMCCHSY
QUIT
IF $PIECE(^BMCDX(BMCCHSY,0),U)=BMCCHSX
IF $PIECE(^(0),U,4)=BMCCHS(.04)
SET BMCCHSQ=1
QUIT
+14 ; found it so decrement COUNT field and delete if 0
IF BMCCHSQ
Begin DoDot:1
+15 SET BMCCHSX=$$VALI^XBDIQ1(90001.01,BMCCHSY,.07)
+16 SET BMCCHSX=BMCCHSX-1
+17 ; delete entry
IF BMCCHSX=0
SET DIK="^BMCDX("
SET DA=BMCCHSY
DO ^DIK
QUIT
+18 ; if count>0 update count and leave entry
+19 SET DR=".07////"_BMCCHSX
SET DIE="^BMCDX("
SET DA=BMCCHSY
+20 DO DIE^BMCFMC
End DoDot:1
QUIT
+21 QUIT
+22 ;---------
PXA(BMCRIEN,BMCCHS) ;EP - ADD PROCEDURE
+1 ; s array(.01)=CPT code ien
+2 ; s array(.02-.07) to appropriate internal values
+3 ; d px^bmcchs(referral_ien,.array_name)
+4 ;
+5 NEW BMCCHSQ,BMCCHSX,BMCCHSY
+6 IF '$GET(BMCRIEN)
QUIT
+7 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+8 SET BMCCHS(.03)=BMCRIEN
+9 SET BMCCHSQ=0
+10 FOR BMCCHSX=.01,.02,.03,.04,.05,.07
IF $GET(BMCCHS(BMCCHSX))=""
SET BMCCHSQ=1
+11 IF BMCCHSQ
QUIT
+12 ;BMC 4.0*2* 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1
IF BMCCHS(.01)=-1
QUIT
+13 SET BMCCHSX=BMCCHS(.01)
SET BMCCHSY=0
+14 ; check for duplicate cpt codes for same TYPE (provisional or final)
+15 FOR
SET BMCCHSY=$ORDER(^BMCPX("AD",BMCRIEN,BMCCHSY))
IF 'BMCCHSY
QUIT
IF $PIECE(^BMCPX(BMCCHSY,0),U)=BMCCHSX
IF $PIECE(^(0),U,4)=BMCCHS(.04)
SET BMCCHSQ=1
QUIT
+16 ; dupe so increment UNITS field
IF BMCCHSQ
Begin DoDot:1
+17 SET BMCCHSX=$GET(BMCCHS(.07))
+18 IF BMCCHSX=""
QUIT
+19 SET BMCCHSX=BMCCHSX+$$VALI^XBDIQ1(90001.02,BMCCHSY,.07)
+20 SET DR=".07////"_BMCCHSX
SET DIE="^BMCPX("
SET DA=BMCCHSY
+21 DO DIE^BMCFMC
End DoDot:1
QUIT
+22 SET DIC("DR")=""
+23 FOR BMCCHSX=.02,.03,.04,.05,.06,.07
IF $GET(BMCCHS(BMCCHSX))'=""
SET DIC("DR")=DIC("DR")_$SELECT(DIC("DR")="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
+24 SET DIC="^BMCPX("
SET DIC(0)="L"
SET DLAYGO=90001.02
SET X=BMCCHS(.01)
+25 DO FILE^BMCFMC
+26 QUIT
+27 ;---------
PXD(BMCRIEN,BMCCHS) ;EP - DELETE PROCEDURE
+1 ; s array(.01)=CPT ien
+2 ; s array(.04)=P or F
+3 ; s array(.07)=number of units
+4 ; d dxd^bmcchs(referral_ien,.array_name)
+5 ;
+6 NEW BMCCHSQ,BMCCHSX,BMCCHSY
+7 IF '$GET(BMCRIEN)
QUIT
+8 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+9 SET BMCCHSQ=0
+10 FOR BMCCHSX=.01,.04,.07
IF $GET(BMCCHS(BMCCHSX))=""
SET BMCCHSQ=1
+11 IF BMCCHSQ
QUIT
+12 SET BMCCHSX=BMCCHS(.01)
SET BMCCHSY=0
+13 ; find cpt code for same TYPE (provisional or final)
+14 FOR
SET BMCCHSY=$ORDER(^BMCPX("AD",BMCRIEN,BMCCHSY))
IF 'BMCCHSY
QUIT
IF $PIECE(^BMCPX(BMCCHSY,0),U)=BMCCHSX
IF $PIECE(^(0),U,4)=BMCCHS(.04)
SET BMCCHSQ=1
QUIT
+15 ; found it so decrement UNITS field and delete if 0
IF BMCCHSQ
Begin DoDot:1
+16 SET BMCCHSX=$$VALI^XBDIQ1(90001.02,BMCCHSY,.07)
+17 SET BMCCHSX=BMCCHSX-BMCCHS(.07)
+18 ; delete entry
IF BMCCHSX<1
SET DIK="^BMCPX("
SET DA=BMCCHSY
DO ^DIK
QUIT
+19 ; if units>0 update units and leave entry
+20 SET DR=".07////"_BMCCHSX
SET DIE="^BMCPX("
SET DA=BMCCHSY
+21 DO DIE^BMCFMC
End DoDot:1
QUIT
+22 QUIT
