BMCAPI2 ; IHS/OIT/FCJ - TOC INTERFACE ; [ 09/22/2006 10:03 AM ]
;;4.0;REFERRED CARE INFO SYSTEM;**8**;JAN 09, 2006;Build 101
;
;IHS/ITSC/FCJ PATCH 8 NEW ROUTINE
;
W:'$D(ZTQUEUED) !!,"NO ENTRY FROM THE TOP OF ^BMCTOC",!!
Q
;
;----------
TOC(BMCRIEN,F,BMCTOC) ;EP - SET TOC ARRAY FOR EHR
; d toc^bmcapi2(referral_ien,"P" OR "G",.array_name)
; BMCRIEN is the IEN of the RCIS REFERRAL
; F is a flag: G to get values, P to put values in file
; BMCTOC is array into which values are set
;
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
D @("STAT"_F)
Q
TOCG ;GET TOC INFORMATION
Q
TOCP ;PUT TOC INFORMATION
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
;----------
VEN(BMCRIEN,BMCTOC) ;EP - VEN TOC INFORMATION
; d stat^bmcchs(referral_ien,.array_name)
; or
; s array(1114)=FAX
; s array(2104)=DIRECT PARTICIPANT YES OR NO
; s array(2105)=DIRECT EMAIL ADDRESS
;
;
; BMCRIEN is the IEN of the RCIS REFERRAL
; BMCTOC is array into which values are set
;
;
Q:'$G(BMCRIEN)
Q:'$D(^BMCREF(BMCRIEN,0))
S BMCVIEN=$P(^BMCREF(BMCRIEN,0),U,7)
Q:'BMCVIEN
F BMCTOCX=1114,2104,2105 S BMCTOC(BMCTOCX)=$$VALI^XBDIQ1(9999999.11,BMCVIEN,BMCTOCX)
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)
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
BMCAPI2 ; IHS/OIT/FCJ - TOC INTERFACE ; [ 09/22/2006 10:03 AM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**8**;JAN 09, 2006;Build 101
+2 ;
+3 ;IHS/ITSC/FCJ PATCH 8 NEW ROUTINE
+4 ;
+5 IF '$DATA(ZTQUEUED)
WRITE !!,"NO ENTRY FROM THE TOP OF ^BMCTOC",!!
+6 QUIT
+7 ;
+8 ;----------
TOC(BMCRIEN,F,BMCTOC) ;EP - SET TOC ARRAY FOR EHR
+1 ; d toc^bmcapi2(referral_ien,"P" OR "G",.array_name)
+2 ; BMCRIEN is the IEN of the RCIS REFERRAL
+3 ; F is a flag: G to get values, P to put values in file
+4 ; BMCTOC is array into which values are set
+5 ;
+6 IF '$GET(BMCRIEN)
QUIT
+7 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+8 DO @("STAT"_F)
+9 QUIT
TOCG ;GET TOC INFORMATION
+1 QUIT
TOCP ;PUT TOC INFORMATION
+1 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
+2 SET BMCCHS(BMCCHSX)=$$VALI^XBDIQ1(90001,BMCRIEN,BMCCHSX)
End DoDot:1
+3 FOR BMCCHSX=1105,1106
Begin DoDot:1
+4 SET BMCCHS(BMCCHSX)=$PIECE(BMCCHS(BMCCHSX),".")
End DoDot:1
+5 QUIT
+6 ;----------
VEN(BMCRIEN,BMCTOC) ;EP - VEN TOC INFORMATION
+1 ; d stat^bmcchs(referral_ien,.array_name)
+2 ; or
+3 ; s array(1114)=FAX
+4 ; s array(2104)=DIRECT PARTICIPANT YES OR NO
+5 ; s array(2105)=DIRECT EMAIL ADDRESS
+6 ;
+7 ;
+8 ; BMCRIEN is the IEN of the RCIS REFERRAL
+9 ; BMCTOC is array into which values are set
+10 ;
+11 ;
+12 IF '$GET(BMCRIEN)
QUIT
+13 IF '$DATA(^BMCREF(BMCRIEN,0))
QUIT
+14 SET BMCVIEN=$PIECE(^BMCREF(BMCRIEN,0),U,7)
+15 IF 'BMCVIEN
QUIT
+16 FOR BMCTOCX=1114,2104,2105
SET BMCTOC(BMCTOCX)=$$VALI^XBDIQ1(9999999.11,BMCVIEN,BMCTOCX)
+17 QUIT
+18 ;
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)
+19 QUIT
+20 ;
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 ;BMC*4.0*8
SET DR=".02///"_$PIECE(BMCCHS(BMCCHSX),U,2)
+20 ;BMC*4.0*8
DO ^DIE
+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
