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