- IBCEF61 ;ALB/TMP - EDI TRANSMISSION RULES DEFINITION ;28-APR-99
- ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
- ;
- SELRULE(IBRULE) ; Select rule
- D FULL^VALM1
- S IBRULE=""
- N IBR,IB
- D EN^VALM2($G(XQORNOD(0)),"S")
- S IBR=0 F S IBR=$O(VALMY(IBR)) Q:'IBR S IB=$G(^TMP("IBCE-RULEDX",$J,IBR)),IBRULE=+$P(IB,U,2)
- Q
- ;
- ACTIVE(IBRULE) ; Edit rules' active/inactive dates
- ; IBRULE = ien of rule in file 364.4
- ;
- G:'$G(IBRULE) ACTQ
- N DA,DR,DIE,X,Y,Z,Z0
- S DA=$G(IBRULE),DIE="^IBE(364.4,"
- S DR=".02;.06"
- D ^DIE
- I $D(Y) S IBRULE=0 G ACTQ
- D REBLD^IBCEF6($G(IBACTIVE))
- ACTQ S VALMBCK="R"
- Q
- ;
- SCRACT ; Rebld display - only currently active
- S IBACTIVE=1
- D REBLD^IBCEF6(1)
- S VALMBCK="R"
- Q
- ;
- NOSCR ; Rebld display - inactive and currently active
- S IBACTIVE=0
- D REBLD^IBCEF6(0)
- S VALMBCK="R"
- Q
- ;
- BILTYP(IBRULE) ; Allow to edit bill types for rule
- ; IBRULE = ien of rule - file 364.4
- ;
- G:'$G(IBRULE) BILTYPQ
- N DA,DR,DIE,X,Y,Z,Z0,IBRT,IB,IBOK,IBCT
- S DA=$G(IBRULE),DIE="^IBE(364.4,",IBRT=$P($G(^IBE(364.4,IBRULE,0)),U,11)
- I $S(IBRT=9:0,1:IBRT'=1) D G BILTYPQ
- . W !
- . S DIR(0)="EA",DIR("A",1)="RULE TYPE '"_$$EXPAND^IBTRE(364.4,.11,IBRT)_"' DOES NOT ALLOW BILL TYPE RESTRICTIONS",DIR("A")="PRESS RETURN " D ^DIR K DIR W !
- S (IBO,IBCT)=0 ;Extract existing entries
- F S IBO=$O(^IBE(364.4,IBRULE,"BTYP",IBO)) Q:'IBO S IBX=$P($G(^(IBO,0)),U),IBO(IBX)=IBO_U_$P(^(0),U,2,3),IBCT=IBCT+1,IB(364.41,IBCT,.01)=IBX,IBI(IBX)=IBCT F Z=2,3 I $P(IBO(IBX),U,Z)'="" S IB(364.41,IBCT,Z/100)=$P(IBO(IBX),U,Z)
- ; Display entries, allow to add/edit/delete
- D EN^IBCEF62
- BILTYPQ S VALMBCK="R"
- Q
- ;
- SEL(VALMY) ; Select one or more bill type restriction entries
- ; VALMY = passed by reference and returned subscripted by
- ; entry #(s) in the LM array selected
- ;
- N Z
- D FULL^VALM1
- N IBR
- D EN^VALM2($G(XQORNOD(0)))
- Q
- ;
- BTEDIT(IBRULE) ; Edit bill type restriction dates
- ; IBRULE = ien of the bill type restriction being edited
- ; (0)= ien of the RULE - file 364.4
- G:'$G(IBRULE) BTEQ
- ;
- N DA,DIE,DR,Y,X,VALMY,Z,IBBT
- ;
- S IBCT=0
- D SEL(.VALMY)
- G:'$O(VALMY(0)) BTEQ ; None selected
- ;
- S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBBT=+$G(^TMP("IBCE-BTDX",$J,Z)) I IBBT D
- . S DA(1)=IBRULE,DA=IBBT,DIE="^IBE(364.4,"_DA(1)_",""BTYP"",",DR=".02;.03"
- . W !!,"Bill Type Restriction #"_Z_" - "_$E($G(^TMP("IBCE-BT",$J,Z,0)),5,50),!
- . D ^DIE
- . D REBLD^IBCEF62
- ;
- BTEQ S VALMBCK="R"
- Q
- ;
- BTADD(IBRULE) ; Add new bill type restrictions
- ; IBRULE = ien of rule entry - file 364.4
- N IB,IBCT,Z,IBOK
- D FULL^VALM1
- G:'$G(IBRULE) BTAQ
- ;
- S (IBCT,Z)=0
- S Z=0 F S Z=$O(^IBE(364.4,IBRULE,"BTYP",Z)) Q:'Z S IBCT=IBCT+1,IB(364.41,IBCT,.01)=$P($G(^(Z,0)),U)
- ;
- D BTYP^IBCEF51(.IB,.IBOK,0)
- ;
- I IBOK D
- . N Z
- . S Z=0 F S Z=$O(^IBE(364.4,IBRULE,"BTYP",Z)) Q:'Z S DA=Z,DA(1)=IBRULE,DIK="^IBE(364.4,"_DA(1)_",""BTYP""," D ^DIK
- . D ADDBTYP(.IB,IBRULE)
- . D REBLD^IBCEF62
- D SUCCESS(IBOK)
- ;
- BTAQ S VALMBCK="R"
- Q
- ;
- INSCO(IBRULE) ; Allow user to edit rule's ins co data
- ; IBRULE = ien of rule - file 364.4
- ;
- G:'$G(IBRULE) INSCOQ
- N DA,DR,DIE,X,Y,Z,Z0,IB,IB0
- S DA=$G(IBRULE),DIE="^IBE(364.4,"
- S IB0=$G(^IBE(364.4,IBRULE,0)),IB(".07O")=$P(IB0,U,7)
- S DR=$S($P(IB0,U,3)'=2:".07;S Y=$S(X=1:""@10"",X=2:""@20"",1:""@99"");",1:"")_"@10;3;S Y=""@99"";@20;2;S Y=""@99"";@99"
- D ^DIE
- S IB(.07)=$P($G(^IBE(364.4,IBRULE,0)),U,7)
- ;
- I IB(".07O"),IB(".07O")'=IB(.07),IB(".07O")'=3 D ; Delete 'old' includes/excludes
- . S Z=$P("3^2",U,+IB(".07O")),Z0=0 F S Z0=$O(^IBE(364.4,IBRULE,Z,Z0)) Q:'Z0 S DA=Z0,DA(1)=IBRULE,DIK="^IBE(364.4,"_DA(1)_","_Z_"," D ^DIK
- ;
- ; If all ins cos selected, delete existing specific ones in/excluded
- I 'IB(.07)!(IB(.07)=3) D
- . Q:IB(".07O")=IB(.07)
- . F Z=2,3 I $O(^IBE(364.4,IBRULE,Z,0)) S Z0=0 F S Z0=$O(^IBE(364.4,IBRULE,Z,Z0)) Q:'Z0 S DA=Z0,DA(1)=IBRULE,DIK="^IBE(364.4,"_DA(1)_","_Z_"," D ^DIK
- E D
- . Q:$O(^IBE(364.4,IBRULE,$S(IB(.07)=1:3,1:2),0))
- . W !,"Warning ... no insurance companies chosen to "_$S(IB(.07)=1:"in",1:"ex")_"clude"
- . D QUIT^IBCEF5
- D REBLD^IBCEF6($G(IBACTIVE))
- ;
- INSCOQ S VALMBCK="R"
- Q
- ;
- MISC(IBRULE) ; Edit other misc fields for the rule
- ; IBRULE = ien of rule - file 364.4
- ;
- I $G(IBRULE) D
- . N DA,DR,DIE,X,Y,Z,Z0
- . S DA=$G(IBRULE),DIE="^IBE(364.4,"
- . S DR=".08;1;4"
- . D ^DIE
- . D REBLD^IBCEF6($G(IBACTIVE))
- S VALMBCK="R"
- Q
- ;
- DISPRUL(IBRULE) ; Display rule selected
- ; IBRULE = ien of rule - file 364.4
- ;
- I '$G(IBRULE) D FULL^VALM1
- N DIOBEG,FR,TO,BY,DIC,DA,L,FLDS,DHD
- S (FR,TO)=$G(IBRULE),DHD="[IBCE RULE DISPLAY HEADER]"
- S L=0,BY="@RULE NUMBER",DIC="^IBE(364.4,",FLDS="[IBCE RULE DISPLAY]"
- S DIOBEG="W !"
- W !!
- D EN1^DIP
- DISPRQ S VALMBCK="R"
- D PAUSE^VALM1
- Q
- ;
- SUCCESS(IBOK) ; Display msg after add rule
- ; IBOK = 1 if successful, 0 if not
- ;
- N DIR,Y,X
- S DIR(0)="EA"
- W !
- I $G(IBOK) S DIR("A",1)="TRANSMISSION RULE(s) HAVE BEEN SUCCESSFULLY FILED"
- I '$G(IBOK) S DIR("A",1)="NO TRANSMISSION RULES ADDED"
- S DIR("A")="PRESS RETURN " D ^DIR K DIR
- S VALMBCK="R"
- Q
- ;
- ADDBTYP(IB,IBDA1) ; Add bill types in IB(364.41) to rule IBDA1
- ;
- N Z,Z0,IBC
- I $D(IB(364.41)) D
- . S IBC=0 F S IBC=$O(IB(364.41,IBC)) Q:'IBC D
- .. N DO,DD,DIC,DLAYGO,DA,X,Y
- .. S Z=.01 F S Z=$O(IB(364.41,IBC,Z)) Q:'Z S Z0=$G(IB(364.41,IBC,Z)) I Z0'="" D ;Bill type excepts
- ... S DIC("DR")=$G(DIC("DR"))_$S($G(DIC("DR"))="":"",1:";")_Z_"///"_Z0
- .. I '$D(^IBE(364.4,IBDA1,"BTYP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(364.4,.1)
- .. S X=IB(364.41,IBC,.01)
- .. S DA(1)=IBDA1,DIC="^IBE(364.4,"_IBDA1_",""BTYP"",",DIC(0)="L",DLAYGO=364.4
- .. D FILE^DICN
- Q
- ;
- INSADD(IB,IBDA1) ; Add ins co exceptions from entries in
- ; IB(364.42 - exclude) or IB(364.43 - include) to rule IBDA1
- ;
- N Z,IBNODE,Z0
- F Z=364.42,364.43 S IBNODE=$E(Z,$L(Z)),Z0=0 F S Z0=$O(IB(Z,Z0)) Q:'Z0 D
- . N DO,DD,DIC,DLAYGO,DA
- . I '$D(^IBE(364.4,IBDA1,IBNODE,0)) S DIC("P")=$$GETSPEC^IBEFUNC(364.4,IBNODE)
- . S DA(1)=IBDA1,DIC="^IBE(364.4,"_IBDA1_","_IBNODE_",",DIC(0)="L",DLAYGO=364.4,X=Z0
- . D FILE^DICN K DIC
- Q
- ;
- BTDTOK(IBRULE,IBBT,IBDTYP,X) ; Check bill type date is consistent for rule
- ; IBRULE = ien of rule - file 364.4
- ; IBBT = ien of bill type in rule IBRULE (optional if check at top level)
- ; IBDTYP = 1 for active date check, 2 for inactive date check
- ; X = Value of date being validated
- ;
- ; Function returns 1 if consistencies are OK, 0 if not
- ;
- N IBOK,IBPCK,Z
- S IBOK=1
- S IBPCK=$S(IBDTYP=1:2,1:6)
- ;
- ; Check for consistency at rule level first
- ;
- ; Active dt must not be after rule's inact dt
- I IBDTYP=1,$P($G(^IBE(364.4,IBRULE,0)),U,6),X>$P(^(0),U,6) S Z=$$FMTE^XLFDT($P($G(^IBE(364.4,IBRULE,0)),U,6)) D EN^DDIOL("CANNOT BE AFTER RULE'S INACTIVE DATE OF "_$S('Z:"<MISSING>",1:Z),,"!!") S IBOK=0 G BTDTQ
- ;
- ; Inact dt must not be prior to rule's active dt
- I IBDTYP=2,$S('$P($G(^IBE(364.4,IBRULE,0)),U,2):'$G(IBBT),1:X<$P($G(^(0)),U,2)) S Z=$$FMTE^XLFDT($P($G(^IBE(364.4,IBRULE,0)),U,2)) D EN^DDIOL("CANNOT BE BEFORE RULE'S ACTIVE DATE OF "_$S('Z:"<MISSING>",1:Z),,"!!") S IBOK=0 G BTDTQ
- ;
- I $G(IBBT) D ; Check for consistency at the bill type level
- . ; Active dt at bt level must be prior to inactive dt
- . I IBDTYP=1,$P($G(^IBE(364.4,IBRULE,"IBTYP",IBBT,0)),U,3),X>$P(^(0),U,3) S Z=$$FMTE^XLFDT($P(^IBE(364.4,IBRULE,"IBTYP",IBBT,0),U,3)) D EN^DDIOL("MUST BE PRIOR TO BILL TYPE'S INACTIVE DATE OF "_$S('Z:"<MISSING>",1:Z),,"!!") S IBOK=0 Q
- . ; Inactive dt at bt level must be after active dt
- . I IBDTYP=2,$S('$P($G(^IBE(364.4,IBRULE,"IBTYP",IBBT,0)),U,2):1,1:X<$P(^(0),U,2)) S Z=$$FMTE^XLFDT($P($G(^IBE(364.4,IBRULE,"IBTYP",IBBT,0)),U,2)) D EN^DDIOL("MUST BE AFTER BILL TYPE'S ACTIVE DATE OF "_$S('Z:"<MISSING>",1:Z),,"!!") S IBOK=0 Q
- . ;
- . S Z=0
- . F S Z=$O(^IBE(364.4,IBRULE,"BTYP",Z)) Q:'Z S Z0=$G(^(Z,0)) D Q:'IBOK
- .. I $P(Z0,U,IBDTYP+1),$S(IBDTYP=1:X<$P(Z0,U,2),1:X>$P(Z0,U,3)) D EN^DDIOL("CHANGE WOULD INVALIDATE BILL TYPE RESTRICTION DATE",,"!!") S IBOK=0
- BTDTQ Q IBOK
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF61 8039 printed Feb 18, 2025@23:36:33 Page 2
- IBCEF61 ;ALB/TMP - EDI TRANSMISSION RULES DEFINITION ;28-APR-99
- +1 ;;2.0;INTEGRATED BILLING;**137**;21-MAR-94
- +2 ;
- SELRULE(IBRULE) ; Select rule
- +1 DO FULL^VALM1
- +2 SET IBRULE=""
- +3 NEW IBR,IB
- +4 DO EN^VALM2($GET(XQORNOD(0)),"S")
- +5 SET IBR=0
- FOR
- SET IBR=$ORDER(VALMY(IBR))
- if 'IBR
- QUIT
- SET IB=$GET(^TMP("IBCE-RULEDX",$JOB,IBR))
- SET IBRULE=+$PIECE(IB,U,2)
- +6 QUIT
- +7 ;
- ACTIVE(IBRULE) ; Edit rules' active/inactive dates
- +1 ; IBRULE = ien of rule in file 364.4
- +2 ;
- +3 if '$GET(IBRULE)
- GOTO ACTQ
- +4 NEW DA,DR,DIE,X,Y,Z,Z0
- +5 SET DA=$GET(IBRULE)
- SET DIE="^IBE(364.4,"
- +6 SET DR=".02;.06"
- +7 DO ^DIE
- +8 IF $DATA(Y)
- SET IBRULE=0
- GOTO ACTQ
- +9 DO REBLD^IBCEF6($GET(IBACTIVE))
- ACTQ SET VALMBCK="R"
- +1 QUIT
- +2 ;
- SCRACT ; Rebld display - only currently active
- +1 SET IBACTIVE=1
- +2 DO REBLD^IBCEF6(1)
- +3 SET VALMBCK="R"
- +4 QUIT
- +5 ;
- NOSCR ; Rebld display - inactive and currently active
- +1 SET IBACTIVE=0
- +2 DO REBLD^IBCEF6(0)
- +3 SET VALMBCK="R"
- +4 QUIT
- +5 ;
- BILTYP(IBRULE) ; Allow to edit bill types for rule
- +1 ; IBRULE = ien of rule - file 364.4
- +2 ;
- +3 if '$GET(IBRULE)
- GOTO BILTYPQ
- +4 NEW DA,DR,DIE,X,Y,Z,Z0,IBRT,IB,IBOK,IBCT
- +5 SET DA=$GET(IBRULE)
- SET DIE="^IBE(364.4,"
- SET IBRT=$PIECE($GET(^IBE(364.4,IBRULE,0)),U,11)
- +6 IF $SELECT(IBRT=9:0,1:IBRT'=1)
- Begin DoDot:1
- +7 WRITE !
- +8 SET DIR(0)="EA"
- SET DIR("A",1)="RULE TYPE '"_$$EXPAND^IBTRE(364.4,.11,IBRT)_"' DOES NOT ALLOW BILL TYPE RESTRICTIONS"
- SET DIR("A")="PRESS RETURN "
- DO ^DIR
- KILL DIR
- WRITE !
- End DoDot:1
- GOTO BILTYPQ
- +9 ;Extract existing entries
- SET (IBO,IBCT)=0
- +10 FOR
- SET IBO=$ORDER(^IBE(364.4,IBRULE,"BTYP",IBO))
- if 'IBO
- QUIT
- SET IBX=$PIECE($GET(^(IBO,0)),U)
- SET IBO(IBX)=IBO_U_$PIECE(^(0),U,2,3)
- SET IBCT=IBCT+1
- SET IB(364.41,IBCT,.01)=IBX
- SET IBI(IBX)=IBCT
- FOR Z=2,3
- IF $PIECE(IBO(IBX),U,Z)'=""
- SET IB(364.41,IBCT,Z/100)=$PIECE(IBO(IBX),U,Z)
- +11 ; Display entries, allow to add/edit/delete
- +12 DO EN^IBCEF62
- BILTYPQ SET VALMBCK="R"
- +1 QUIT
- +2 ;
- SEL(VALMY) ; Select one or more bill type restriction entries
- +1 ; VALMY = passed by reference and returned subscripted by
- +2 ; entry #(s) in the LM array selected
- +3 ;
- +4 NEW Z
- +5 DO FULL^VALM1
- +6 NEW IBR
- +7 DO EN^VALM2($GET(XQORNOD(0)))
- +8 QUIT
- +9 ;
- BTEDIT(IBRULE) ; Edit bill type restriction dates
- +1 ; IBRULE = ien of the bill type restriction being edited
- +2 ; (0)= ien of the RULE - file 364.4
- +3 if '$GET(IBRULE)
- GOTO BTEQ
- +4 ;
- +5 NEW DA,DIE,DR,Y,X,VALMY,Z,IBBT
- +6 ;
- +7 SET IBCT=0
- +8 DO SEL(.VALMY)
- +9 ; None selected
- if '$ORDER(VALMY(0))
- GOTO BTEQ
- +10 ;
- +11 SET Z=0
- FOR
- SET Z=$ORDER(VALMY(Z))
- if 'Z
- QUIT
- SET IBBT=+$GET(^TMP("IBCE-BTDX",$JOB,Z))
- IF IBBT
- Begin DoDot:1
- +12 SET DA(1)=IBRULE
- SET DA=IBBT
- SET DIE="^IBE(364.4,"_DA(1)_",""BTYP"","
- SET DR=".02;.03"
- +13 WRITE !!,"Bill Type Restriction #"_Z_" - "_$EXTRACT($GET(^TMP("IBCE-BT",$JOB,Z,0)),5,50),!
- +14 DO ^DIE
- +15 DO REBLD^IBCEF62
- End DoDot:1
- +16 ;
- BTEQ SET VALMBCK="R"
- +1 QUIT
- +2 ;
- BTADD(IBRULE) ; Add new bill type restrictions
- +1 ; IBRULE = ien of rule entry - file 364.4
- +2 NEW IB,IBCT,Z,IBOK
- +3 DO FULL^VALM1
- +4 if '$GET(IBRULE)
- GOTO BTAQ
- +5 ;
- +6 SET (IBCT,Z)=0
- +7 SET Z=0
- FOR
- SET Z=$ORDER(^IBE(364.4,IBRULE,"BTYP",Z))
- if 'Z
- QUIT
- SET IBCT=IBCT+1
- SET IB(364.41,IBCT,.01)=$PIECE($GET(^(Z,0)),U)
- +8 ;
- +9 DO BTYP^IBCEF51(.IB,.IBOK,0)
- +10 ;
- +11 IF IBOK
- Begin DoDot:1
- +12 NEW Z
- +13 SET Z=0
- FOR
- SET Z=$ORDER(^IBE(364.4,IBRULE,"BTYP",Z))
- if 'Z
- QUIT
- SET DA=Z
- SET DA(1)=IBRULE
- SET DIK="^IBE(364.4,"_DA(1)_",""BTYP"","
- DO ^DIK
- +14 DO ADDBTYP(.IB,IBRULE)
- +15 DO REBLD^IBCEF62
- End DoDot:1
- +16 DO SUCCESS(IBOK)
- +17 ;
- BTAQ SET VALMBCK="R"
- +1 QUIT
- +2 ;
- INSCO(IBRULE) ; Allow user to edit rule's ins co data
- +1 ; IBRULE = ien of rule - file 364.4
- +2 ;
- +3 if '$GET(IBRULE)
- GOTO INSCOQ
- +4 NEW DA,DR,DIE,X,Y,Z,Z0,IB,IB0
- +5 SET DA=$GET(IBRULE)
- SET DIE="^IBE(364.4,"
- +6 SET IB0=$GET(^IBE(364.4,IBRULE,0))
- SET IB(".07O")=$PIECE(IB0,U,7)
- +7 SET DR=$SELECT($PIECE(IB0,U,3)'=2:".07;S Y=$S(X=1:""@10"",X=2:""@20"",1:""@99"");",1:"")_"@10;3;S Y=""@99"";@20;2;S Y=""@99"";@99"
- +8 DO ^DIE
- +9 SET IB(.07)=$PIECE($GET(^IBE(364.4,IBRULE,0)),U,7)
- +10 ;
- +11 ; Delete 'old' includes/excludes
- IF IB(".07O")
- IF IB(".07O")'=IB(.07)
- IF IB(".07O")'=3
- Begin DoDot:1
- +12 SET Z=$PIECE("3^2",U,+IB(".07O"))
- SET Z0=0
- FOR
- SET Z0=$ORDER(^IBE(364.4,IBRULE,Z,Z0))
- if 'Z0
- QUIT
- SET DA=Z0
- SET DA(1)=IBRULE
- SET DIK="^IBE(364.4,"_DA(1)_","_Z_","
- DO ^DIK
- End DoDot:1
- +13 ;
- +14 ; If all ins cos selected, delete existing specific ones in/excluded
- +15 IF 'IB(.07)!(IB(.07)=3)
- Begin DoDot:1
- +16 if IB(".07O")=IB(.07)
- QUIT
- +17 FOR Z=2,3
- IF $ORDER(^IBE(364.4,IBRULE,Z,0))
- SET Z0=0
- FOR
- SET Z0=$ORDER(^IBE(364.4,IBRULE,Z,Z0))
- if 'Z0
- QUIT
- SET DA=Z0
- SET DA(1)=IBRULE
- SET DIK="^IBE(364.4,"_DA(1)_","_Z_","
- DO ^DIK
- End DoDot:1
- +18 IF '$TEST
- Begin DoDot:1
- +19 if $ORDER(^IBE(364.4,IBRULE,$SELECT(IB(.07)=1
- QUIT
- +20 WRITE !,"Warning ... no insurance companies chosen to "_$SELECT(IB(.07)=1:"in",1:"ex")_"clude"
- +21 DO QUIT^IBCEF5
- End DoDot:1
- +22 DO REBLD^IBCEF6($GET(IBACTIVE))
- +23 ;
- INSCOQ SET VALMBCK="R"
- +1 QUIT
- +2 ;
- MISC(IBRULE) ; Edit other misc fields for the rule
- +1 ; IBRULE = ien of rule - file 364.4
- +2 ;
- +3 IF $GET(IBRULE)
- Begin DoDot:1
- +4 NEW DA,DR,DIE,X,Y,Z,Z0
- +5 SET DA=$GET(IBRULE)
- SET DIE="^IBE(364.4,"
- +6 SET DR=".08;1;4"
- +7 DO ^DIE
- +8 DO REBLD^IBCEF6($GET(IBACTIVE))
- End DoDot:1
- +9 SET VALMBCK="R"
- +10 QUIT
- +11 ;
- DISPRUL(IBRULE) ; Display rule selected
- +1 ; IBRULE = ien of rule - file 364.4
- +2 ;
- +3 IF '$GET(IBRULE)
- DO FULL^VALM1
- +4 NEW DIOBEG,FR,TO,BY,DIC,DA,L,FLDS,DHD
- +5 SET (FR,TO)=$GET(IBRULE)
- SET DHD="[IBCE RULE DISPLAY HEADER]"
- +6 SET L=0
- SET BY="@RULE NUMBER"
- SET DIC="^IBE(364.4,"
- SET FLDS="[IBCE RULE DISPLAY]"
- +7 SET DIOBEG="W !"
- +8 WRITE !!
- +9 DO EN1^DIP
- DISPRQ SET VALMBCK="R"
- +1 DO PAUSE^VALM1
- +2 QUIT
- +3 ;
- SUCCESS(IBOK) ; Display msg after add rule
- +1 ; IBOK = 1 if successful, 0 if not
- +2 ;
- +3 NEW DIR,Y,X
- +4 SET DIR(0)="EA"
- +5 WRITE !
- +6 IF $GET(IBOK)
- SET DIR("A",1)="TRANSMISSION RULE(s) HAVE BEEN SUCCESSFULLY FILED"
- +7 IF '$GET(IBOK)
- SET DIR("A",1)="NO TRANSMISSION RULES ADDED"
- +8 SET DIR("A")="PRESS RETURN "
- DO ^DIR
- KILL DIR
- +9 SET VALMBCK="R"
- +10 QUIT
- +11 ;
- ADDBTYP(IB,IBDA1) ; Add bill types in IB(364.41) to rule IBDA1
- +1 ;
- +2 NEW Z,Z0,IBC
- +3 IF $DATA(IB(364.41))
- Begin DoDot:1
- +4 SET IBC=0
- FOR
- SET IBC=$ORDER(IB(364.41,IBC))
- if 'IBC
- QUIT
- Begin DoDot:2
- +5 NEW DO,DD,DIC,DLAYGO,DA,X,Y
- +6 ;Bill type excepts
- SET Z=.01
- FOR
- SET Z=$ORDER(IB(364.41,IBC,Z))
- if 'Z
- QUIT
- SET Z0=$GET(IB(364.41,IBC,Z))
- IF Z0'=""
- Begin DoDot:3
- +7 SET DIC("DR")=$GET(DIC("DR"))_$SELECT($GET(DIC("DR"))="":"",1:";")_Z_"///"_Z0
- End DoDot:3
- +8 IF '$DATA(^IBE(364.4,IBDA1,"BTYP",0))
- SET DIC("P")=$$GETSPEC^IBEFUNC(364.4,.1)
- +9 SET X=IB(364.41,IBC,.01)
- +10 SET DA(1)=IBDA1
- SET DIC="^IBE(364.4,"_IBDA1_",""BTYP"","
- SET DIC(0)="L"
- SET DLAYGO=364.4
- +11 DO FILE^DICN
- End DoDot:2
- End DoDot:1
- +12 QUIT
- +13 ;
- INSADD(IB,IBDA1) ; Add ins co exceptions from entries in
- +1 ; IB(364.42 - exclude) or IB(364.43 - include) to rule IBDA1
- +2 ;
- +3 NEW Z,IBNODE,Z0
- +4 FOR Z=364.42,364.43
- SET IBNODE=$EXTRACT(Z,$LENGTH(Z))
- SET Z0=0
- FOR
- SET Z0=$ORDER(IB(Z,Z0))
- if 'Z0
- QUIT
- Begin DoDot:1
- +5 NEW DO,DD,DIC,DLAYGO,DA
- +6 IF '$DATA(^IBE(364.4,IBDA1,IBNODE,0))
- SET DIC("P")=$$GETSPEC^IBEFUNC(364.4,IBNODE)
- +7 SET DA(1)=IBDA1
- SET DIC="^IBE(364.4,"_IBDA1_","_IBNODE_","
- SET DIC(0)="L"
- SET DLAYGO=364.4
- SET X=Z0
- +8 DO FILE^DICN
- KILL DIC
- End DoDot:1
- +9 QUIT
- +10 ;
- BTDTOK(IBRULE,IBBT,IBDTYP,X) ; Check bill type date is consistent for rule
- +1 ; IBRULE = ien of rule - file 364.4
- +2 ; IBBT = ien of bill type in rule IBRULE (optional if check at top level)
- +3 ; IBDTYP = 1 for active date check, 2 for inactive date check
- +4 ; X = Value of date being validated
- +5 ;
- +6 ; Function returns 1 if consistencies are OK, 0 if not
- +7 ;
- +8 NEW IBOK,IBPCK,Z
- +9 SET IBOK=1
- +10 SET IBPCK=$SELECT(IBDTYP=1:2,1:6)
- +11 ;
- +12 ; Check for consistency at rule level first
- +13 ;
- +14 ; Active dt must not be after rule's inact dt
- +15 IF IBDTYP=1
- IF $PIECE($GET(^IBE(364.4,IBRULE,0)),U,6)
- IF X>$PIECE(^(0),U,6)
- SET Z=$$FMTE^XLFDT($PIECE($GET(^IBE(364.4,IBRULE,0)),U,6))
- DO EN^DDIOL("CANNOT BE AFTER RULE'S INACTIVE DATE OF "_$SELECT('Z:"<MISSING>",1:Z),,"!!")
- SET IBOK=0
- GOTO BTDTQ
- +16 ;
- +17 ; Inact dt must not be prior to rule's active dt
- +18 IF IBDTYP=2
- IF $SELECT('$PIECE($GET(^IBE(364.4,IBRULE,0)),U,2):'$GET(IBBT),1:X<$PIECE($GET(^(0)),U,2))
- SET Z=$$FMTE^XLFDT($PIECE($GET(^IBE(364.4,IBRULE,0)),U,2))
- DO EN^DDIOL("CANNOT BE BEFORE RULE'S ACTIVE DATE OF "_$SELECT('Z:"<MISSING>",1:Z),,"!!")
- SET IBOK=0
- GOTO BTDTQ
- +19 ;
- +20 ; Check for consistency at the bill type level
- IF $GET(IBBT)
- Begin DoDot:1
- +21 ; Active dt at bt level must be prior to inactive dt
- +22 IF IBDTYP=1
- IF $PIECE($GET(^IBE(364.4,IBRULE,"IBTYP",IBBT,0)),U,3)
- IF X>$PIECE(^(0),U,3)
- SET Z=$$FMTE^XLFDT($PIECE(^IBE(364.4,IBRULE,"IBTYP",IBBT,0),U,3))
- DO EN^DDIOL("MUST BE PRIOR TO BILL TYPE'S INACTIVE DATE OF "_$SELECT('Z:"<MISSING>",1:Z),,"!!")
- SET IBOK=0
- QUIT
- +23 ; Inactive dt at bt level must be after active dt
- +24 IF IBDTYP=2
- IF $SELECT('$PIECE($GET(^IBE(364.4,IBRULE,"IBTYP",IBBT,0)),U,2):1,1:X<$PIECE(^(0),U,2))
- SET Z=$$FMTE^XLFDT($PIECE($GET(^IBE(364.4,IBRULE,"IBTYP",IBBT,0)),U,2))
- DO EN^DDIOL("MUST BE AFTER BILL TYPE'S ACTIVE DATE OF "_$SELECT('Z:"<MISSING>",1:Z),,"!!")
- SET IBOK=0
- QUIT
- +25 ;
- +26 SET Z=0
- +27 FOR
- SET Z=$ORDER(^IBE(364.4,IBRULE,"BTYP",Z))
- if 'Z
- QUIT
- SET Z0=$GET(^(Z,0))
- Begin DoDot:2
- +28 IF $PIECE(Z0,U,IBDTYP+1)
- IF $SELECT(IBDTYP=1:X<$PIECE(Z0,U,2),1:X>$PIECE(Z0,U,3))
- DO EN^DDIOL("CHANGE WOULD INVALIDATE BILL TYPE RESTRICTION DATE",,"!!")
- SET IBOK=0
- End DoDot:2
- if 'IBOK
- QUIT
- End DoDot:1
- BTDTQ QUIT IBOK
- +1 ;