- 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 Mar 13, 2025@21:41 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 ;
