IBYOPRE ;ALB/TMP - IB*2*51 PRE-INSTALL ;22-JAN-96
;;2.0;INTEGRATED BILLING;**51**;21-MAR-94
;
N DIK,DA,IBX,DA,IBXREF
D BMES^XPDUTL("Pre-Installation Updates")
D BMES^XPDUTL("Delete xrefs and output formatter data that will be updated during install")
I $D(^IBA(355.93)) G OVER ; Already installed once - skip some parts
D DELIX^DDMOD(399,.08,3)
S IBX=" >> ^DD(399,.08) cross reference #3 deleted." D MES^XPDUTL(IBX)
D DELIX^DDMOD(364.6,.04,2) K ^IBA(364.6,"D")
S IBX=" >> ^DD(364.6,.04) cross reference #2 deleted." D MES^XPDUTL(IBX)
;
; Perform maintenance to clean up the output formatter file 364.5
D FIXIT^IBYOPRE1
OVER ;
D BMES^XPDUTL("Checking for Output Formatter Local Print Field Overrides")
N IB1,IBFM,IBFREC,IBFF,IBFFREC,IBREC,IBZ,IBZ0,I,Q,Q0,Z,Z0
D BMES^XPDUTL("INTEGRATED BILLING LOCAL PRINT FIELD OVERRIDES")
S IBX=$J("",18)_"DESCRIPTION"_$J("",11)_"DATA ELEMENT" D BMES^XPDUTL(IBX)
S IBX="",$P(IBX,"-",81)="" D MES^XPDUTL(IBX)
K ^TMP($J)
S I=9999 F S I=$O(^IBA(364.6,I)) Q:'I D
. I '$D(^IBA(364.7,"B",I)) Q
. S IBFM=$G(^IBA(364.6,I,0)),IBFREC=$G(^IBE(353,$P(IBFM,U),2))
. I $P(IBFM,U,3)="" Q
. I $P(IBFREC,U,2)="S" Q
. S IBFF=0 F S IBFF=$O(^IBA(364.7,"B",I,IBFF)) Q:'IBFF S IBFFREC=$G(^IBA(364.7,IBFF,0)) D
.. S IBREC=$G(^IBA(364.6,+$P(IBFM,U,3),0))
.. I IBREC'="" S ^TMP($J,+IBFM,+$P(IBREC,U,5),+$P(IBREC,U,8),IBFF)=+$P($G(^IBA(364.6,+$P(IBFM,U,3),0)),U)
S IBFM=0 F S IBFM=$O(^TMP($J,IBFM)) Q:'IBFM D MES^XPDUTL(" ") S IBX=" LOCAL PRINT FORM NAME: "_$P($G(^IBE(353,+IBFM,0)),U),IB1=1 D BMES^XPDUTL(IBX) D
. S IBZ="" F S IBZ=$O(^TMP($J,IBFM,IBZ)) Q:IBZ="" S IBZ0="" F S IBZ0=$O(^TMP($J,IBFM,IBZ,IBZ0)) Q:IBZ0="" D
.. N DIWL,X,DIWR,DIWF
.. S IBFF=0 F S IBFF=$O(^TMP($J,IBFM,IBZ,IBZ0,IBFF)) Q:'IBFF S IBFFREC=$G(^IBA(364.7,IBFF,0)),IBREC=$G(^IBA(364.6,+IBFFREC,0)) D
... I IB1 S IBX=$J("",12)_"PARENT FORM: "_$P($G(^IBE(353,+^TMP($J,IBFM,IBZ,IBZ0,IBFF),0)),U) D MES^XPDUTL(IBX)
... S IBX=$E("LINE: "_$J(IBZ,2)_"/COL: "_IBZ0_$J("",18),1,18)_$E($P(IBREC,U,10)_$J("",20),1,20)_" "_$P($G(^IBA(364.5,+$P(IBFFREC,U,3),0)),U) D
.... I 'IB1 D MES^XPDUTL(IBX) Q
.... D BMES^XPDUTL(IBX) S IB1=0
... S IBX=$J("",18)_"("
... I $P(IBFFREC,U,5)'="" S IBX=IBX_"INSURANCE CO: "_$P($G(^DIC(36,+$P(IBFFREC,U,5),0)),U)
... I $P(IBFFREC,U,6)'="" S IBX=IBX_$S($P(IBX,"(",2)="":"",1:" ")_"BILL TYPE: "_$$EXPAND^IBTRE(364.7,.06,$P(IBFFREC,U,6))
... I $P(IBX,"(",2)'="" S IBX=IBX_")" D MES^XPDUTL(IBX)
... S IBX=$J("",9)_"CODE: "
... I $G(^IBA(364.7,IBFF,1))'="" K ^UTILITY($J,"W") S X=^IBA(364.7,IBFF,1),DIWL=1,DIWF="C54" D ^DIWP S Q=0 F S Q=$O(^UTILITY($J,"W",Q)) Q:'Q S Q0=0 F S Q0=$O(^UTILITY($J,"W",Q,Q0)) Q:'Q0 D MES^XPDUTL(IBX_^(Q0,0)) S IBX=$J("",15)
... I $O(^IBA(364.7,IBFF,3,0)) K ^UTILITY($J,"W") D
.... S Q=0 F S Q=$O(^IBA(364.7,IBFF,3,Q)) Q:'Q S X=$G(^IBA(364.7,IBFF,3,Q,0)),DIWL=1,DIWF="C54" D ^DIWP
.... S IBX=$J("",9)_"DESC: "
.... S Q=0 F S Q=$O(^UTILITY($J,"W",Q)) Q:'Q S Q0=0 F S Q0=$O(^UTILITY($J,"W",Q,Q0)) Q:'Q0 D MES^XPDUTL(IBX_^(Q0,0)) S IBX=$J("",15)
... D MES^XPDUTL(" ")
... K ^UTILITY($J,"W")
K ^UTILITY($J,"W"),^TMP($J)
;
; Perform maintenance on entries in file 364.5
S DIE="^IBA(364.6,",DR=".05////46",DA=710 I $D(^IBA(364.6,710,0)) D ^DIE
I $D(^IBA(364.7,317,0)),$P(^(0),U,3)'=296 S DIE="^IBA(364.7,",DR=".03////296",DA=317 D ^DIE ; Alpha sites only
I $D(^IBA(364.7,491,0)),$P(^(0),U,3)'=296 S DIE="^IBA(364.7,",DR=".03////296",DA=491 D ^DIE ; Alpha sites only
D ENT5
;
S IBX=" >> Output formatter entries delete/update completed." D BMES^XPDUTL(IBX)
;
I '$D(^IBA(355.93)) D ; Only do this the first time installed
. S IBX=0 F S IBX=$O(^IBA(364.6,IBX)) Q:'IBX D
.. N Z,Z0,Z2,Z12
.. S Z0=+$G(^IBA(364.6,IBX,0)),Z2=$G(^IBE(353,Z0,2)),Z12=$G(^IBE(353,+$P(Z2,U,5),2))
.. I Z0=8!($P(Z2,U,2)="P"&($S($P(Z2,U,4):1,1:$P(Z12,U,4)))) D
... S Z=0 F S Z=$O(^IBA(364.7,"B",IBX,Z)) Q:'Z S DIK="^IBA(364.7,",DA=Z D ^DIK
... S DIK="^IBA(364.6,",DA=IBX D ^DIK
. S IBX=" >> Output formatter files cleaned up." D MES^XPDUTL(IBX)
;
Q
;
ENT5 ; Change name of entries in 364.5, delete unused ones
N Z,Z0,Z1,DA,IB,DIK,IBDA
;
S Z1="N-BALANCE DUE^N-CURR INSURANCE CO STREET^N-CURR INSURANCE CO CITY^N-CURR INSURANCE CO STATE^N-CURR INSURANCE CO ZIP CODE^N-UB92 ADMISSION DATE^N-STATE CODE FOR ACCIDENT^N-HCFA 1500 BOX 19 (LINE 2)^N-SPACER FOR 81 COLUMN UB-92"
F Z0=1:1:$L(Z1,U) S Z=$P(Z1,U,Z0) I Z1'="" D
. S IBDA=$O(^IBA(364.5,"B",Z,0)) I IBDA D
.. S IB=0 F S IB=$O(^IBA(364.7,"C",IBDA,IB)) Q:'IB S DA=IB,DIK="^IBA(364.7," D ^DIK
.. S DIK="^IBA(364.5,",DA=IBDA D ^DIK
;
S DA=+$O(^IBA(364.5,"B","N-TREATMENT AUTHORIZATION CODE",0))
I DA S DIE="^IBA(364.5,",DR=".01////N-PRIMARY AUTH CODE" D ^DIE
;
S DA=+$O(^IBA(364.5,"B","N-HCFA 1500 BOX 19 (LINE 1)",0))
I DA S DIE="^IBA(364.5,",DR=".01////N-HCFA 1500 BOX 19;.08///@" D ^DIE
;
S DA=+$O(^IBA(364.5,"B","N-OTH INS EMPLOYMENT STAT",0))
I DA S DIE="^IBA(364.5,",DR=".01////N-OTHER INSURED EMPLOY STATUS" D ^DIE
S DA=+$O(^IBA(364.5,"B","N-ATTENDING PHYSICIAN",0))
I DA S DIE="^IBA(364.5,",DR=".01////N-ATT/REND PHYSICIAN NAME" D ^DIE
;
S Z=0 F S Z=$O(^IBA(364.5,Z)) Q:'Z S F=$P($G(^IBA(364.5,Z,0)),U,6) I F'="" D
. I F="TREATMENT AUTHORIZATION CODE" S DIE="^IBA(364.5,",DA=Z,DR=".06////PRIMARY AUTH CODE" D ^DIE
F Z="N-LOCATION OF CARE","N-BILL CLASSIFICATION","N-TIMEFRAME OF BILL" D
. S DA=+$O(^IBA(364.5,"B",Z,0))
. I DA S DIE="^IBA(364.5,",DR=".07///@" D ^DIE ; remove internal indicator from fields
S DA=+$O(^IBA(364.5,"B","N-HCFA 1500 EIN FLAG (BOX 25)",0))
I DA S DIE="^IBA(364.5,",DR=".08///@" D ^DIE
;Delete old descriptions - new ones are shorter
F DA=9,16,31,33,102,153,160,169,178 K ^IBA(364.5,DA,3)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBYOPRE 5801 printed Dec 13, 2024@02:35:49 Page 2
IBYOPRE ;ALB/TMP - IB*2*51 PRE-INSTALL ;22-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**51**;21-MAR-94
+2 ;
+3 NEW DIK,DA,IBX,DA,IBXREF
+4 DO BMES^XPDUTL("Pre-Installation Updates")
+5 DO BMES^XPDUTL("Delete xrefs and output formatter data that will be updated during install")
+6 ; Already installed once - skip some parts
IF $DATA(^IBA(355.93))
GOTO OVER
+7 DO DELIX^DDMOD(399,.08,3)
+8 SET IBX=" >> ^DD(399,.08) cross reference #3 deleted."
DO MES^XPDUTL(IBX)
+9 DO DELIX^DDMOD(364.6,.04,2)
KILL ^IBA(364.6,"D")
+10 SET IBX=" >> ^DD(364.6,.04) cross reference #2 deleted."
DO MES^XPDUTL(IBX)
+11 ;
+12 ; Perform maintenance to clean up the output formatter file 364.5
+13 DO FIXIT^IBYOPRE1
OVER ;
+1 DO BMES^XPDUTL("Checking for Output Formatter Local Print Field Overrides")
+2 NEW IB1,IBFM,IBFREC,IBFF,IBFFREC,IBREC,IBZ,IBZ0,I,Q,Q0,Z,Z0
+3 DO BMES^XPDUTL("INTEGRATED BILLING LOCAL PRINT FIELD OVERRIDES")
+4 SET IBX=$JUSTIFY("",18)_"DESCRIPTION"_$JUSTIFY("",11)_"DATA ELEMENT"
DO BMES^XPDUTL(IBX)
+5 SET IBX=""
SET $PIECE(IBX,"-",81)=""
DO MES^XPDUTL(IBX)
+6 KILL ^TMP($JOB)
+7 SET I=9999
FOR
SET I=$ORDER(^IBA(364.6,I))
if 'I
QUIT
Begin DoDot:1
+8 IF '$DATA(^IBA(364.7,"B",I))
QUIT
+9 SET IBFM=$GET(^IBA(364.6,I,0))
SET IBFREC=$GET(^IBE(353,$PIECE(IBFM,U),2))
+10 IF $PIECE(IBFM,U,3)=""
QUIT
+11 IF $PIECE(IBFREC,U,2)="S"
QUIT
+12 SET IBFF=0
FOR
SET IBFF=$ORDER(^IBA(364.7,"B",I,IBFF))
if 'IBFF
QUIT
SET IBFFREC=$GET(^IBA(364.7,IBFF,0))
Begin DoDot:2
+13 SET IBREC=$GET(^IBA(364.6,+$PIECE(IBFM,U,3),0))
+14 IF IBREC'=""
SET ^TMP($JOB,+IBFM,+$PIECE(IBREC,U,5),+$PIECE(IBREC,U,8),IBFF)=+$PIECE($GET(^IBA(364.6,+$PIECE(IBFM,U,3),0)),U)
End DoDot:2
End DoDot:1
+15 SET IBFM=0
FOR
SET IBFM=$ORDER(^TMP($JOB,IBFM))
if 'IBFM
QUIT
DO MES^XPDUTL(" ")
SET IBX=" LOCAL PRINT FORM NAME: "_$PIECE($GET(^IBE(353,+IBFM,0)),U)
SET IB1=1
DO BMES^XPDUTL(IBX)
Begin DoDot:1
+16 SET IBZ=""
FOR
SET IBZ=$ORDER(^TMP($JOB,IBFM,IBZ))
if IBZ=""
QUIT
SET IBZ0=""
FOR
SET IBZ0=$ORDER(^TMP($JOB,IBFM,IBZ,IBZ0))
if IBZ0=""
QUIT
Begin DoDot:2
+17 NEW DIWL,X,DIWR,DIWF
+18 SET IBFF=0
FOR
SET IBFF=$ORDER(^TMP($JOB,IBFM,IBZ,IBZ0,IBFF))
if 'IBFF
QUIT
SET IBFFREC=$GET(^IBA(364.7,IBFF,0))
SET IBREC=$GET(^IBA(364.6,+IBFFREC,0))
Begin DoDot:3
+19 IF IB1
SET IBX=$JUSTIFY("",12)_"PARENT FORM: "_$PIECE($GET(^IBE(353,+^TMP($JOB,IBFM,IBZ,IBZ0,IBFF),0)),U)
DO MES^XPDUTL(IBX)
+20 SET IBX=$EXTRACT("LINE: "_$JUSTIFY(IBZ,2)_"/COL: "_IBZ0_$JUSTIFY("",18),1,18)_$EXTRACT($PIECE(IBREC,U,10)_$JUSTIFY("",20),1,20)_" "_$PIECE($GET(^IBA(364.5,+$PIECE(IBFFREC,U,3),0)),U)
Begin DoDot:4
+21 IF 'IB1
DO MES^XPDUTL(IBX)
QUIT
+22 DO BMES^XPDUTL(IBX)
SET IB1=0
End DoDot:4
+23 SET IBX=$JUSTIFY("",18)_"("
+24 IF $PIECE(IBFFREC,U,5)'=""
SET IBX=IBX_"INSURANCE CO: "_$PIECE($GET(^DIC(36,+$PIECE(IBFFREC,U,5),0)),U)
+25 IF $PIECE(IBFFREC,U,6)'=""
SET IBX=IBX_$SELECT($PIECE(IBX,"(",2)="":"",1:" ")_"BILL TYPE: "_$$EXPAND^IBTRE(364.7,.06,$PIECE(IBFFREC,U,6))
+26 IF $PIECE(IBX,"(",2)'=""
SET IBX=IBX_")"
DO MES^XPDUTL(IBX)
+27 SET IBX=$JUSTIFY("",9)_"CODE: "
+28 IF $GET(^IBA(364.7,IBFF,1))'=""
KILL ^UTILITY($JOB,"W")
SET X=^IBA(364.7,IBFF,1)
SET DIWL=1
SET DIWF="C54"
DO ^DIWP
SET Q=0
FOR
SET Q=$ORDER(^UTILITY($JOB,"W",Q))
if 'Q
QUIT
SET Q0=0
FOR
SET Q0=$ORDER(^UTILITY($JOB,"W",Q,Q0))
if 'Q0
QUIT
DO MES^XPDUTL(IBX_^(Q0,0))
SET IBX=$JUSTIFY("",15)
+29 IF $ORDER(^IBA(364.7,IBFF,3,0))
KILL ^UTILITY($JOB,"W")
Begin DoDot:4
+30 SET Q=0
FOR
SET Q=$ORDER(^IBA(364.7,IBFF,3,Q))
if 'Q
QUIT
SET X=$GET(^IBA(364.7,IBFF,3,Q,0))
SET DIWL=1
SET DIWF="C54"
DO ^DIWP
+31 SET IBX=$JUSTIFY("",9)_"DESC: "
+32 SET Q=0
FOR
SET Q=$ORDER(^UTILITY($JOB,"W",Q))
if 'Q
QUIT
SET Q0=0
FOR
SET Q0=$ORDER(^UTILITY($JOB,"W",Q,Q0))
if 'Q0
QUIT
DO MES^XPDUTL(IBX_^(Q0,0))
SET IBX=$JUSTIFY("",15)
End DoDot:4
+33 DO MES^XPDUTL(" ")
+34 KILL ^UTILITY($JOB,"W")
End DoDot:3
End DoDot:2
End DoDot:1
+35 KILL ^UTILITY($JOB,"W"),^TMP($JOB)
+36 ;
+37 ; Perform maintenance on entries in file 364.5
+38 SET DIE="^IBA(364.6,"
SET DR=".05////46"
SET DA=710
IF $DATA(^IBA(364.6,710,0))
DO ^DIE
+39 ; Alpha sites only
IF $DATA(^IBA(364.7,317,0))
IF $PIECE(^(0),U,3)'=296
SET DIE="^IBA(364.7,"
SET DR=".03////296"
SET DA=317
DO ^DIE
+40 ; Alpha sites only
IF $DATA(^IBA(364.7,491,0))
IF $PIECE(^(0),U,3)'=296
SET DIE="^IBA(364.7,"
SET DR=".03////296"
SET DA=491
DO ^DIE
+41 DO ENT5
+42 ;
+43 SET IBX=" >> Output formatter entries delete/update completed."
DO BMES^XPDUTL(IBX)
+44 ;
+45 ; Only do this the first time installed
IF '$DATA(^IBA(355.93))
Begin DoDot:1
+46 SET IBX=0
FOR
SET IBX=$ORDER(^IBA(364.6,IBX))
if 'IBX
QUIT
Begin DoDot:2
+47 NEW Z,Z0,Z2,Z12
+48 SET Z0=+$GET(^IBA(364.6,IBX,0))
SET Z2=$GET(^IBE(353,Z0,2))
SET Z12=$GET(^IBE(353,+$PIECE(Z2,U,5),2))
+49 IF Z0=8!($PIECE(Z2,U,2)="P"&($SELECT($PIECE(Z2,U,4):1,1:$PIECE(Z12,U,4))))
Begin DoDot:3
+50 SET Z=0
FOR
SET Z=$ORDER(^IBA(364.7,"B",IBX,Z))
if 'Z
QUIT
SET DIK="^IBA(364.7,"
SET DA=Z
DO ^DIK
+51 SET DIK="^IBA(364.6,"
SET DA=IBX
DO ^DIK
End DoDot:3
End DoDot:2
+52 SET IBX=" >> Output formatter files cleaned up."
DO MES^XPDUTL(IBX)
End DoDot:1
+53 ;
+54 QUIT
+55 ;
ENT5 ; Change name of entries in 364.5, delete unused ones
+1 NEW Z,Z0,Z1,DA,IB,DIK,IBDA
+2 ;
+3 SET Z1="N-BALANCE DUE^N-CURR INSURANCE CO STREET^N-CURR INSURANCE CO CITY^N-CURR INSURANCE CO STATE^N-CURR INSURANCE CO ZIP CODE^N-UB92 ADMISSION DATE^N-STATE CODE FOR ACCIDENT^N-HCFA 1500 BOX 19 (LINE 2)^N-SPACER FOR 81 COLUMN UB-92"
+4 FOR Z0=1:1:$LENGTH(Z1,U)
SET Z=$PIECE(Z1,U,Z0)
IF Z1'=""
Begin DoDot:1
+5 SET IBDA=$ORDER(^IBA(364.5,"B",Z,0))
IF IBDA
Begin DoDot:2
+6 SET IB=0
FOR
SET IB=$ORDER(^IBA(364.7,"C",IBDA,IB))
if 'IB
QUIT
SET DA=IB
SET DIK="^IBA(364.7,"
DO ^DIK
+7 SET DIK="^IBA(364.5,"
SET DA=IBDA
DO ^DIK
End DoDot:2
End DoDot:1
+8 ;
+9 SET DA=+$ORDER(^IBA(364.5,"B","N-TREATMENT AUTHORIZATION CODE",0))
+10 IF DA
SET DIE="^IBA(364.5,"
SET DR=".01////N-PRIMARY AUTH CODE"
DO ^DIE
+11 ;
+12 SET DA=+$ORDER(^IBA(364.5,"B","N-HCFA 1500 BOX 19 (LINE 1)",0))
+13 IF DA
SET DIE="^IBA(364.5,"
SET DR=".01////N-HCFA 1500 BOX 19;.08///@"
DO ^DIE
+14 ;
+15 SET DA=+$ORDER(^IBA(364.5,"B","N-OTH INS EMPLOYMENT STAT",0))
+16 IF DA
SET DIE="^IBA(364.5,"
SET DR=".01////N-OTHER INSURED EMPLOY STATUS"
DO ^DIE
+17 SET DA=+$ORDER(^IBA(364.5,"B","N-ATTENDING PHYSICIAN",0))
+18 IF DA
SET DIE="^IBA(364.5,"
SET DR=".01////N-ATT/REND PHYSICIAN NAME"
DO ^DIE
+19 ;
+20 SET Z=0
FOR
SET Z=$ORDER(^IBA(364.5,Z))
if 'Z
QUIT
SET F=$PIECE($GET(^IBA(364.5,Z,0)),U,6)
IF F'=""
Begin DoDot:1
+21 IF F="TREATMENT AUTHORIZATION CODE"
SET DIE="^IBA(364.5,"
SET DA=Z
SET DR=".06////PRIMARY AUTH CODE"
DO ^DIE
End DoDot:1
+22 FOR Z="N-LOCATION OF CARE","N-BILL CLASSIFICATION","N-TIMEFRAME OF BILL"
Begin DoDot:1
+23 SET DA=+$ORDER(^IBA(364.5,"B",Z,0))
+24 ; remove internal indicator from fields
IF DA
SET DIE="^IBA(364.5,"
SET DR=".07///@"
DO ^DIE
End DoDot:1
+25 SET DA=+$ORDER(^IBA(364.5,"B","N-HCFA 1500 EIN FLAG (BOX 25)",0))
+26 IF DA
SET DIE="^IBA(364.5,"
SET DR=".08///@"
DO ^DIE
+27 ;Delete old descriptions - new ones are shorter
+28 FOR DA=9,16,31,33,102,153,160,169,178
KILL ^IBA(364.5,DA,3)
+29 QUIT
+30 ;
