Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCAPI2

BMCAPI2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;IHS/ITSC/FCJ PATCH 8 NEW ROUTINE
  1.  ;
  1.  W:'$D(ZTQUEUED) !!,"NO ENTRY FROM THE TOP OF ^BMCTOC",!!
  1.  Q
  1.  ;
  1.  ;----------
  1. TOC(BMCRIEN,F,BMCTOC) ;EP - SET TOC ARRAY FOR EHR
  1.  ; d toc^bmcapi2(referral_ien,"P" OR "G",.array_name)
  1.  ; BMCRIEN is the IEN of the RCIS REFERRAL
  1.  ; F is a flag:  G to get values, P to put values in file
  1.  ; BMCTOC is array into which values are set
  1.  ;
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  D @("STAT"_F)
  1.  Q
  1. TOCG ;GET TOC INFORMATION
  1.  Q
  1. TOCP ;PUT TOC INFORMATION
  1.  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
  1.  .S BMCCHS(BMCCHSX)=$$VALI^XBDIQ1(90001,BMCRIEN,BMCCHSX)
  1.  F BMCCHSX=1105,1106 D
  1.  .S BMCCHS(BMCCHSX)=$P(BMCCHS(BMCCHSX),".")
  1.  Q
  1.  ;----------
  1. VEN(BMCRIEN,BMCTOC)         ;EP - VEN TOC INFORMATION
  1.  ; d stat^bmcchs(referral_ien,.array_name)
  1.  ;   or
  1.  ; s array(1114)=FAX
  1.  ; s array(2104)=DIRECT PARTICIPANT YES OR NO
  1.  ; s array(2105)=DIRECT EMAIL ADDRESS
  1.  ;
  1.  ;
  1.  ; BMCRIEN is the IEN of the RCIS REFERRAL
  1.  ; BMCTOC is array into which values are set
  1.  ; 
  1.  ;
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  S BMCVIEN=$P(^BMCREF(BMCRIEN,0),U,7)
  1.  Q:'BMCVIEN
  1.  F BMCTOCX=1114,2104,2105 S BMCTOC(BMCTOCX)=$$VALI^XBDIQ1(9999999.11,BMCVIEN,BMCTOCX)
  1.  Q
  1.  ;
  1. STATP ; SET CHS STATUS INFORMATION
  1.  S DIE="^BMCREF(",DA=BMCRIEN,DR=""
  1.  ;BMC*4.0*8 ADDED 6120 TO NXT LINE
  1.  F BMCCHSX=1112,1113,1114,6120 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
  1.  Q:DR=""
  1.  D DIE^BMCFMC
  1.  S DIE="^BMCREF(",DA=BMCRIEN,DR=""
  1.  I $G(BMCCHS(1128))'="" D
  1.  .;4.0 IHS/OIT/FCJ CHG NXT SECTION TO TEST FOR PARAMETER
  1.  .;F BMCCHSX=.07,.15,1106,1128 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
  1.  .F BMCCHSX=.07,.14,1106,1128 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
  1.  .I $P($G(^BMCPARM(DUZ(2),4100)),U,3)="Y" D
  1.  ..S BMCCHSX=.15
  1.  ..S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
  1.  .Q:DR=""
  1.  .D DIE^BMCFMC
  1.  Q
  1.  ;----------
  1. AUTH(BMCRIEN,BMCAIEN,F,BMCCHS) ;EP - CHS AUTHORIZATIONS MULTIPLE
  1.  ; d auth^bmcchs(referral_ien,authorization_ien,"G",.array_name)
  1.  ;   or
  1.  ; s array(.02)=dollar value
  1.  ; d auth^bmcchs(referral_ien,authorization_ien,"P",.array_name)
  1.  ;   or
  1.  ; d auth^bmcchs(referral_ien,authorization_ien,"D")
  1.  ;
  1.  ; BMCRIEN is the referral ien
  1.  ; BMCAIEN is the CHS AUTHORIZATION ien
  1.  ; BMCCHS is the variable array root
  1.  ; F is a flag:  G to get values, P to put values in file, D to
  1.  ;               delete entries
  1.  ;
  1.  NEW BMCCHSV,BMCCHSX
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  Q:'$G(BMCAIEN)
  1.  D @("AUTH"_F)
  1.  Q
  1.  ;
  1. AUTHG ; GET CHS AUTHORIZATION VALUES
  1.  Q:'$D(^BMCREF(BMCRIEN,41,BMCAIEN,0))
  1.  F BMCCHSX=.02,.03,.04,.05,.06,.07,.08,.09,.13 S BMCCHS(BMCCHSX)=""
  1.  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"
  1.  D DIQ1^BMCFMC
  1.  F BMCCHSX=.02,.03,.04,.05,.06,.07,.08,.09,.13 S BMCCHS(BMCCHSX)=$G(BMCCHSV(90001.41,BMCAIEN,BMCCHSX,"I"))
  1.  Q
  1.  ;
  1. AUTHP ; SET CHS AUTHORIZATION VALUES INTO FILE
  1.  I '$D(^BMCREF(BMCRIEN,41,BMCAIEN,0)) D AUTHPADD Q
  1.  D AUTHPMOD
  1.  Q
  1.  ;
  1. AUTHPADD ; ADD NEW CHS AUTHORIZATION
  1.  S DIC("DR")=""
  1.  F BMCCHSX=.02,.03,.04,.05,.06,.07,.08 S:$G(BMCCHS(BMCCHSX))'="" DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
  1.  I $G(BMCCHS(.09))'="" S DIC("DR")=DIC("DR")_";.09////"_BMCCHS(.09)
  1.  I $G(BMCCHS(.13))'="" S DIC("DR")=DIC("DR")_";.13////"_BMCCHS(.13)
  1.  S DIC="^BMCREF("_BMCRIEN_",41,",DIC(0)="L",DA(1)=BMCRIEN,DIC("P")=$P(^DD(90001,4100,0),U,2),X=BMCAIEN,DINUM=BMCAIEN
  1.  D FILE^BMCFMC
  1.  Q
  1. AUTHPMOD ; MODIFY EXISTING CHS AUTHORIZATION
  1.  S DR=""
  1.  F BMCCHSX=.02,.03,.04,.05,.06,.07,.08 S:$G(BMCCHS(BMCCHSX))'="" DR=DR_$S(DR="":"",1:";")_BMCCHSX_"///"_BMCCHS(BMCCHSX)
  1.  I $G(BMCCHS(.09))'="" S DR=DR_";.09////"_BMCCHS(.09)
  1.  I $G(BMCCHS(.13))'="" S DR=DR_";.13////"_BMCCHS(.13)
  1.  S DIE="^BMCREF("_BMCRIEN_",41,",DA(1)=BMCRIEN,DA=BMCAIEN
  1.  D DIE^BMCFMC
  1.  Q
  1.  ;
  1. AUTHD ; DELETE CHS AUTHORIZATION ENTRY
  1.  Q:'$D(^BMCREF(BMCRIEN,41,BMCAIEN,0))
  1.  S DIK="^BMCREF("_BMCRIEN_",41,",DA=BMCAIEN,DA(1)=BMCRIEN
  1.  D DIK^BMCFMC
  1.  Q
  1.  ;---------
  1.  ;IHS/ITSC/FCJ ADDED NXT SECTION
  1. DENIAL ;TEST AND ADD MULT DENIAL PROVIDERS AND MULT DENIAL REASONS
  1.  S BMCCHSX=4300,BMCCHSP=0,BMCCHSR=0,DIC("DR")=""
  1.  F  S BMCCHSX=$O(BMCCHS(BMCCHSX)) Q:(BMCCHSX>4499)!(BMCCHSX'?1N.N)  D
  1.  .;Q:BMCCHS(BMCCHSX)=""  S X="`"_BMCCHS(BMCCHSX)  ;BMC*4.0*8
  1.  .Q:BMCCHS(BMCCHSX)=""  S X="`"_+BMCCHS(BMCCHSX)  ;BMC*4.0*8
  1.  .I BMCCHSX>4400 D
  1.  ..S BMCCHSP=BMCCHSP+1
  1.  ..S DIC="^BMCREF("_BMCRIEN_",44,",DIC(0)="L",DLAYGO=90001
  1.  ..S DA(1)=BMCRIEN
  1.  ..I '$D(^BMCREF(BMCRIEN,44,0)) S ^BMCREF(BMCRIEN,44,0)="^90001.44PA^0^0"
  1.  ..D ^DIC
  1.  ..K DIE,DIC,DA,X,Y,DLAYGO
  1.  .E  I BMCCHSX<4400 D
  1.  ..S BMCCHSR=BMCCHSR+1
  1.  ..;BMC*4.0*8 ADDED DIE TO NEXT LINE
  1.  ..S (DIE,DIC)="^BMCREF("_BMCRIEN_",43,",DIC(0)="L",DLAYGO=90001
  1.  ..S DA(1)=BMCRIEN
  1.  ..I '$D(^BMCREF(BMCRIEN,43,0)) S ^BMCREF(BMCRIEN,43,0)="^90001.43PA^0^0"
  1.  ..D ^DIC
  1.  ..S DR=".02///"_$P(BMCCHS(BMCCHSX),U,2)  ;BMC*4.0*8
  1.  ..D ^DIE   ;BMC*4.0*8
  1.  ..K DIE,DIC,DA,X,Y,DLAYGO
  1.  K DIE,DIC,DA,X,Y,DLAYGO
  1.  Q
  1.  ;---------
  1. DXA(BMCRIEN,BMCCHS) ;EP - ADD DIAGNOSIS
  1.  ; s array(.01)=ICD9 ien
  1.  ; s array(.02-.06) to appropriate internal values
  1.  ; d dxa^bmcchs(referral_ien,.array_name)
  1.  ;
  1.  NEW BMCCHSQ,BMCCHSX,BMCCHSY
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  S BMCCHS(.03)=BMCRIEN
  1.  S BMCCHSQ=0
  1.  F BMCCHSX=.01,.02,.03,.04,.05 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
  1.  Q:BMCCHS(.01)=-1  ;BMC 4.0*2 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1
  1.  Q:BMCCHSQ
  1.  S BMCCHSX=BMCCHS(.01),BMCCHSY=0
  1.  ;  check for duplicate icd9 codes for same TYPE (provisional or final)
  1.  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
  1.  I BMCCHSQ D  Q  ;               dupe so increment COUNT field
  1.  . S BMCCHSX=$$VALI^XBDIQ1(90001.01,BMCCHSY,.07)
  1.  . S BMCCHSX=BMCCHSX+1
  1.  . S DR=".07////"_BMCCHSX,DIE="^BMCDX(",DA=BMCCHSY
  1.  . D DIE^BMCFMC
  1.  S DIC("DR")=""
  1.  F BMCCHSX=.02,.03,.04,.05,.06 S:$G(BMCCHS(BMCCHSX))'="" DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
  1.  S DIC("DR")=DIC("DR")_";.07////1"
  1.  S DIC="^BMCDX(",DIC(0)="L",DLAYGO=90001.01,X=BMCCHS(.01)
  1.  D FILE^BMCFMC
  1.  Q
  1.  ;---------
  1. DXD(BMCRIEN,BMCCHS) ;EP - DELETE DIAGNOSIS
  1.  ; s array(.01)=ICD9 ien
  1.  ; s array(.04)=P or F
  1.  ; d dxd^bmcchs(referral_ien,.array_name)
  1.  ;
  1.  NEW BMCCHSQ,BMCCHSX,BMCCHSY
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  S BMCCHSQ=0
  1.  F BMCCHSX=.01,.04 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
  1.  Q:BMCCHSQ
  1.  S BMCCHSX=BMCCHS(.01),BMCCHSY=0
  1.  ;  find icd9 code for same TYPE (provisional or final)
  1.  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
  1.  I BMCCHSQ D  Q  ;    found it so decrement COUNT field and delete if 0
  1.  . S BMCCHSX=$$VALI^XBDIQ1(90001.01,BMCCHSY,.07)
  1.  . S BMCCHSX=BMCCHSX-1
  1.  . I BMCCHSX=0 S DIK="^BMCDX(",DA=BMCCHSY D ^DIK Q  ; delete entry
  1.  .; if count>0 update count and leave entry
  1.  . S DR=".07////"_BMCCHSX,DIE="^BMCDX(",DA=BMCCHSY
  1.  . D DIE^BMCFMC
  1.  Q
  1.  ;---------
  1. PXA(BMCRIEN,BMCCHS) ;EP - ADD PROCEDURE
  1.  ; s array(.01)=CPT code ien
  1.  ; s array(.02-.07) to appropriate internal values
  1.  ; d px^bmcchs(referral_ien,.array_name)
  1.  ;
  1.  NEW BMCCHSQ,BMCCHSX,BMCCHSY
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  S BMCCHS(.03)=BMCRIEN
  1.  S BMCCHSQ=0
  1.  F BMCCHSX=.01,.02,.03,.04,.05,.07 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
  1.  Q:BMCCHSQ
  1.  Q:BMCCHS(.01)=-1  ;BMC 4.0*2* 6.5.06 IHS/OIT/FCJ CHS IS PASSING -1
  1.  S BMCCHSX=BMCCHS(.01),BMCCHSY=0
  1.  ;  check for duplicate cpt codes for same TYPE (provisional or final)
  1.  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
  1.  I BMCCHSQ D  Q  ;               dupe so increment UNITS field
  1.  . S BMCCHSX=$G(BMCCHS(.07))
  1.  . Q:BMCCHSX=""
  1.  . S BMCCHSX=BMCCHSX+$$VALI^XBDIQ1(90001.02,BMCCHSY,.07)
  1.  . S DR=".07////"_BMCCHSX,DIE="^BMCPX(",DA=BMCCHSY
  1.  . D DIE^BMCFMC
  1.  S DIC("DR")=""
  1.  F BMCCHSX=.02,.03,.04,.05,.06,.07 S:$G(BMCCHS(BMCCHSX))'="" DIC("DR")=DIC("DR")_$S(DIC("DR")="":"",1:";")_BMCCHSX_"////"_BMCCHS(BMCCHSX)
  1.  S DIC="^BMCPX(",DIC(0)="L",DLAYGO=90001.02,X=BMCCHS(.01)
  1.  D FILE^BMCFMC
  1.  Q
  1.  ;---------
  1. PXD(BMCRIEN,BMCCHS) ;EP - DELETE PROCEDURE
  1.  ; s array(.01)=CPT ien
  1.  ; s array(.04)=P or F
  1.  ; s array(.07)=number of units
  1.  ; d dxd^bmcchs(referral_ien,.array_name)
  1.  ;
  1.  NEW BMCCHSQ,BMCCHSX,BMCCHSY
  1.  Q:'$G(BMCRIEN)
  1.  Q:'$D(^BMCREF(BMCRIEN,0))
  1.  S BMCCHSQ=0
  1.  F BMCCHSX=.01,.04,.07 S:$G(BMCCHS(BMCCHSX))="" BMCCHSQ=1
  1.  Q:BMCCHSQ
  1.  S BMCCHSX=BMCCHS(.01),BMCCHSY=0
  1.  ;  find cpt code for same TYPE (provisional or final)
  1.  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
  1.  I BMCCHSQ D  Q  ;    found it so decrement UNITS field and delete if 0
  1.  . S BMCCHSX=$$VALI^XBDIQ1(90001.02,BMCCHSY,.07)
  1.  . S BMCCHSX=BMCCHSX-BMCCHS(.07)
  1.  . I BMCCHSX<1 S DIK="^BMCPX(",DA=BMCCHSY D ^DIK Q  ; delete entry
  1.  .; if units>0 update units and leave entry
  1.  . S DR=".07////"_BMCCHSX,DIE="^BMCPX(",DA=BMCCHSY
  1.  . D DIE^BMCFMC
  1.  Q