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

IBY137PO.m

Go to the documentation of this file. 
  1. IBY137PO ;ALB/TMP - IB*2*137 POST-INSTALL ;23-AUG-2000
  1.  ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
  1.  ;
  1. POST ;Set up check points for post-init
  1.  S %=$$NEWCP^XPDUTL("U399","U399^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("U3993","U3993^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("U36","U36^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("U3509","U3509^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("UPDPID","PID^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("UPDPTYP","PTYPE^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("UPDNDC","NDCFMT^IBY137PO")
  1.  S %=$$NEWCP^XPDUTL("END","END^IBY137PO") ; Leave as last update
  1.  Q
  1.  ;
  1. U3993 N Z,DA,DIE,X,Y,DR
  1.  D BMES^XPDUTL("Updating RATE TYPE file with electronic billable flag")
  1.  F Z="SHARING AGREEMENT","REIMBURSABLE INS.","CHAMPVA","CHAMPVA REIMB. INS.","CHAMPUS","CHAMPUS REIMB. INS." S DA=$O(^DGCR(399.3,"B",Z,"")) I DA,'$P(^DGCR(399.3,DA,0),U,10) S DIE="^DGCR(399.3,",DR=".1////1" D ^DIE
  1.  D COMPLETE
  1.  Q
  1.  ;
  1. PID ; Use insurance co's TYPE OF COVERAGE field to default its perf prov
  1.  ; id type ... Default TYPE OF COVERAGE, if none, is HEALTH INSURANCE
  1.  D BMES^XPDUTL("Updating insurance co electronic ins type and default prov ID parameters")
  1.  N IBUPIN,IBZ,IB3,IB4,IBZ0,IBZ02,IB,DR,DIE,DA,X,Y
  1.  S IBZ=0 F  S IBZ=$O(^DIC(36,IBZ)) Q:'IBZ  S IBZ0=+$P($G(^(IBZ,0)),U,13) I '$P($G(^(0)),U,5) D
  1.  . S IBZ02=$P($G(^IBE(355.2,IBZ0,0)),U,2),DR=""
  1.  . I IBZ02="",'IBZ0 S IBZ02="HI"
  1.  . Q:IBZ02=""
  1.  . I "^DII^IN^TF^WC^MCL^"[(U_IBZ02_U) Q  ; No default
  1.  . S IB3=$G(^DIC(36,IBZ,3)),IB4=$G(^(4))
  1.  . ; Medicare
  1.  . I IBZ02="MCR" D  Q:DR=""
  1.  .. S DR=".04////VAD000",DIE="^IBE(355.97,",IBUPIN=$$UPIN^IBCEP() I IBUPIN,'$P($G(^IBE(355.97,IBUPIN,0)),U,4) S DA=IBUPIN D ^DIE
  1.  .. S DR=$S('$P(IB3,U,9):"3.09////3",1:"")
  1.  .. S DR=DR_$S($P(IB4,U)="":$S($G(IBUPIN):";4.01////"_IBUPIN_";4.02////2",1:""),1:"")
  1.  . ; Medicaid
  1.  . I IBZ02="MCD",$P(IB3,U,9)="" S DR="3.09////4"
  1.  . ; ChampVA
  1.  . I IBZ02="CHV",$P(IB3,U,9)="" S DR="3.09////9"
  1.  . ; Blue Cross
  1.  . I IBZ02="BC" S DR=$S($P(IB4,U)="":"4.01////1",1:"")_$S($P(IB4,U,2)="":";4.02////3",1:"")_$S($P(IB3,U,9)="":";3.09////9",1:"")
  1.  . ; Blue Shield
  1.  . I IBZ02="BS" S DR=$S($P(IB4,U)="":"4.01////2",1:"")_$S($P(IB4,U,2)="":";4.02////3",1:"")_$S($P(IB3,U,9)="":";3.09////9",1:"")
  1.  . ; Champus
  1.  . I IBZ02="CHS" S DR=$S($P(IB4,U)="":"4.01////3",1:"")_$S($P(IB3,U,9)="":";3.09////9",1:"")
  1.  . ; Commercial/Group or HMO if not one of the above
  1.  . I DR="" D
  1.  .. S DR=$S($P(IB4,U)="":"4.01////6",1:"")_$S($P(IB4,U,2)="":";4.02////3",1:"")_$S($P(IB4,U,3)="":";4.03////2",1:"")_$S($P(IB4,U,10)="":";4.1////16",1:"")_$S($P(IB4,U,11)="":";4.11////2",1:"")
  1.  .. S DR=DR_$S($P(IB3,U,9)="":";3.09///"_$S(IBZ02="HMO":1,1:5),1:"")
  1.  . S:$E(DR)=";" DR=$E(DR,2,$L(DR))
  1.  . I IBZ,DR'="" S DIE="^DIC(36,",DA=IBZ D ^DIE
  1.  D COMPLETE
  1.  Q
  1.  ;
  1. PTYPE ; Update the insurance co plans' electronic id type
  1.  ;
  1.  D BMES^XPDUTL("Adding ELECTRONIC PLAN TYPE for each plan") ; based on major category of plan
  1.  ; If TYPE OF INSURANCE COVERAGE for the plan's insurance company
  1.  ;   is BLUE CROSS or BLUE SHIELD, this is a BC/BS plan type if the
  1.  ;   MAJOR CATEGORY of the plan is not one of the specific ones listed
  1.  ;   below
  1.  ;
  1.  ;  MAJOR CATEGORY      ELECTRONIC PLAN TYPE  
  1.  ; ----------------    ----------------------
  1.  ;       HMO                   HMO
  1.  ;       PPO                   PPO
  1.  ;    MEDICAIDE              MEDICAID
  1.  ;    MEDICARE            MEDICARE A OR B
  1.  ;     CHAMPUS                CHAMPUS
  1.  ;    INDEMNITY              INDEMNITY
  1.  ;
  1.  ;  NONE OF ABOVE/NOT BCBS   COMMERCIAL
  1.  ;
  1.  N IBINS,IBZ,IBZ0,DA,DIE,DR,X,Y
  1.  S IBDA=0 F  S IBDA=$O(^IBA(355.3,IBDA)) Q:'IBDA  D
  1.  . S IBZ0=$G(^IBE(355.1,+$P($G(^IBA(355.3,IBDA,0)),U,9),0))
  1.  . S IBINS=+$P($G(^DIC(36,+$G(^IBA(355.3,IBDA,0)),0)),U,13),IBINS=$P($G(^IBE(355.2,IBINS,0)),U)
  1.  . S IBZ=$P(IBZ0,U,3)
  1.  . S IBZ=$S(IBZ=3:"HM",IBZ=4:12,IBZ=5:"MX",IBZ=6:"MC",IBZ=7:"CH",IBZ=9:15,IBINS="BLUE CROSS"!(IBINS="BLUE SHIELD"):"BL",1:"CI")
  1.  . I $P($G(^IBA(355.3,IBDA,0)),U,15)="" S DIE="^IBA(355.3,",DR=".15////"_IBZ,DA=IBDA D ^DIE
  1.  ;
  1.  D COMPLETE
  1.  Q
  1.  ;
  1. U399 ; Change free text pointer to variable pointer in file 399.0222 - add
  1.  ;  entry in file 355.93 if needed
  1.  ; Start on bills authorized 10-1-2000 or later
  1.  N A,IBZ,IBZ0,DIC,DA,DR,DIE,DLAYGO,DD,DO,X,X0,Y,IBVAP,IBLAST,IBRESTRT,IBMATCH,IBA2,IBA
  1.  D BMES^XPDUTL("Converting provider free text data to pointers in PROVIDER multiple of BILL/CLAIMS file")
  1.  S IBLAST=$$PARCP^XPDUTL("U399") ;Restart parameter
  1.  S:IBLAST="" IBLAST="3001001^0"
  1.  S IBRESTRT=$P(IBLAST,U,2)
  1.  S IBZ=IBLAST-.0000001
  1.  S ^XTMP("IB20_P137_IBPRV",0)=$$FMADD^XLFDT(DT,10)_U_DT_U_"IB PATCH 137 NON-VA PROVIDER DATA"
  1.  F  S IBZ=$O(^DGCR(399,"APD",IBZ)) Q:'IBZ  S IBZ0=IBRESTRT,IBRESTRT=0 F  S IBZ0=$O(^DGCR(399,"APD",IBZ,IBZ0)) Q:'IBZ0  I $D(^DGCR(399,IBZ0,0)) D
  1.  . S IBZ1=0 F  S IBZ1=$O(^DGCR(399,IBZ0,"PRV",IBZ1)) Q:'IBZ1  S A=$G(^(IBZ1,0)) I $P(A,U,2)'="",$P(A,U,2)'[";VA(200",$P(A,U,2)'[";IBA(355.93" D
  1.  .. S X=+$P($P(A,U,2),"(",2)
  1.  .. S DA(1)=IBZ0,DA=IBZ1
  1.  .. ; provider is non-VA (in file 355.93)
  1.  .. I 'X D  Q
  1.  ... S IBA=$$UP^XLFSTR($P(A,U,2))
  1.  ... S IBMATCH=0,IBA2=$$NOPUNCT^IBCEF(IBA,1)
  1.  ... ; Strip all punctuation and spaces and make all upper case
  1.  ... S X0=0 F  S X0=$O(^XTMP("IB20_P137_IBPRV",IBA2,X0)) Q:'X0  D  Q:IBMATCH
  1.  .... Q:'X0
  1.  .... I $$UP^XLFSTR($P($G(^IBA(355.93,X0,0)),U,3))=$$UP^XLFSTR($P(A,U,3)) S IBMATCH=1
  1.  ... I X0 S DR=".02////^S X=IBVAP",IBVAP=X0_";IBA(355.93,",DIE="^DGCR(399,"_DA(1)_",""PRV""," D ^DIE S %=$$UPCP^XPDUTL("U399",IBZ_U_IBZ0) Q
  1.  ... K DO,DD
  1.  ... S DIC="^IBA(355.93,",X=$E(IBA,1,30),DIC(0)="L",DIC("DR")=".02////2"_$S($P(A,U,3)'="":";.03////"_$P(A,U,3),1:""),DLAYGO=355.93 D FILE^DICN K DO,DD,DLAYGO
  1.  ... I Y>0 S DA(1)=IBZ0,DA=IBZ1,^XTMP("IB20_P137_IBPRV",IBA2,+Y)="",DR=".02////^S X=IBVAP",IBVAP=+Y_";IBA(355.93,",DIE="^DGCR(399,"_DA(1)_",""PRV""," D ^DIE
  1.  ... S %=$$UPCP^XPDUTL("U399",IBZ_U_IBZ0)
  1.  .. ;
  1.  .. ; provider is VA (in file 200)
  1.  .. E  D
  1.  ... S DR=".02////^S X=IBVAP",IBVAP=X_";VA(200,",DIE="^DGCR(399,"_DA(1)_",""PRV""," D ^DIE Q
  1.  .. S %=$$UPCP^XPDUTL("U399",IBZ_U_IBZ0)
  1.  K ^XTMP("IB20_P137_IBPRV"),^XTMP("IB20_P137")
  1.  D COMPLETE
  1.  Q
  1.  ;
  1. U36 N IBZ,IBACT,CT
  1.  I $D(^IBE(350.9,1,8)) D BMES^XPDUTL("Update of INSURANCE CO with EDI inactive status done-not rerun"),COMPLETE Q
  1.  D BMES^XPDUTL("Updating INSURANCE file with EDI inactive status")
  1.  S CT=0
  1.  S IBZ=+$$PARCP^XPDUTL("U36"),IBACT=0
  1.  F  S IBZ=$O(^DIC(36,IBZ)) Q:'IBZ  S CT=CT+1 S:'(CT#50) %=$$UPCP^XPDUTL("U36",IBZ) I $D(^DIC(36,IBZ,0)),$P($G(^(3)),U)="" S DIE="^DIC(36,",DA=IBZ,DR="3.01////0" D ^DIE
  1.  D COMPLETE
  1.  Q
  1.  ;
  1. NDCFMT ;
  1.  N Z,DA,DIK,CT
  1.  D BMES^XPDUTL("Executing the new NDC format's cross reference - file 362.4")
  1.  S CT=0
  1.  S Z=+$$PARCP^XPDUTL("UPDNDC") F  S Z=$O(^IBA(362.4,Z)) Q:'Z  S CT=CT+1 S:'(CT#50) %=$$UPCP^XPDUTL("UPDNDC",Z) I $P($G(^IBA(362.4,Z,0)),U,8)'="",$P(^(0),U,9)="" S DA=Z,DIK="^IBA(362.4,",DIK(1)=".08" D EN1^DIK
  1.  D COMPLETE
  1.  Q
  1.  ;
  1. U3509 ; Update site parameters with EDI default data
  1.  D BMES^XPDUTL("Adding QUEUE names and EDI default data to PARAMETERS FILE")
  1.  I $D(^IBE(350.9,1)),$G(^(1,8))="" D
  1.  . S DIE="^IBE(350.9,",DA=1,DR="8.01////MCR;8.09////MCT;8.07////0;8.1////0" D ^DIE
  1.  D COMPLETE
  1.  Q
  1.  ;
  1.  ;  The following code is used strictly for creating the build in the
  1.  ; development account.  It has no value at an individual site.  Do not
  1.  ; use this code to re-build the build at the site.
  1. DDFOR837(Y) ; Code to execute to decide if the data element definition 
  1.  ;  should be sent with this patch ... either it exists in the list at
  1.  ;  line ENT5+2 or below or it is output only by the 837 output form (#8)
  1.  N IBOUT,Z,Z0
  1.  I Y>9999 S IBOUT=0 G Q1
  1.  I ($P($T(ENT5+2),";;",2)[(U_+Y_U)!($P($T(ENT5+3),";;",2)[(U_+Y_U))) S IBOUT=1 G Q1
  1.  I '$O(^IBA(364.7,"C",+Y,0)) S IBOUT=0 G Q1
  1.  S IBOUT=1,Z=0 F  S Z=$O(^IBA(364.7,"C",+Y,Z)) Q:'Z  S Z0=+$G(^IBA(364.7,Z,0)) I +$G(^IBA(364.6,Z0,0))'=8 S IBOUT=0 Q
  1. Q1 Q +$G(IBOUT)
  1.  ;
  1. ERRMSG(TEXT) ; Report errors in array TEXT(error #)=text
  1.  Q:'$O(TEXT(0))
  1.  N Z,Z0
  1.  S Z0="",$P(Z0,"*",29)=""
  1.  D BMES^XPDUTL(" ")
  1.  D MES^XPDUTL(Z0_"ERROR"_Z0)
  1.  S Z=0 F  S Z=$O(TEXT(Z)) Q:'Z  D MES^XPDUTL(TEXT(Z))
  1.  D MES^XPDUTL(Z0_"*****"_Z0)
  1.  D BMES^XPDUTL(" ")
  1.  Q
  1.  ;
  1. ENT5 ; Changed and new entries from 364.5  (other than those only on the 837)
  1.  ;   that should be in the build
  1.  ;;^80^86^98^123^142^194^195^275^297^ ; changed, but not ref-ed by 837
  1.  ;;
  1.  ;;^218^224^225^226^227^228^234^236^249^256^265^290^292^297^ ; ref'd by 837
  1.  Q
  1.  ;
  1. ENT7 ; Changed and new entries from 364.7  (other than those on the 837 form)
  1.  ;   that should be in the build
  1.  ;;^LIVE^251^259^275^276^292^293^317^505^623^630^634^635^724^736^737^799^
  1.  Q
  1.  ;
  1. COMPLETE ;
  1.  D BMES^XPDUTL("Step complete.")
  1.  Q
  1.  ;
  1. END ;
  1.  D BMES^XPDUTL("Post install complete.")
  1.  Q
  1.  ;