- IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
- ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- NEW(IB) ; Add care unit
- ; Assumes IBINS is defined as ins co ien (file 36)
- ; IB = 0 or null if called from list manager, 1 if not
- N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK
- I '$G(IB) D FULL^VALM1
- ;
- ; Add an entry - either new care unit/ins co or a combination for
- ; existing care unit/ins co
- S DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: ",DIC="^IBA(355.95,",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC(0)="AELMQ",DIC("DR")=".03////"_+$G(IBINS)_";.02",DLAYGO=355.95 D ^DIC K DIC,DLAYGO
- G:Y'>0 NEWQ
- S IB95=3,IB95("IBCU")=+Y
- D INSASS(IBINS,.IB95)
- I '$G(IB) D BLD^IBCEP4
- NEWQ I '$G(IB) S VALMBCK="R"
- Q
- ;
- CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS
- ; Assumes IBINS is defined as ins co ien (file 36)
- ; IB = 0 or null if called from list manager, 1 if not
- N DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT
- I '$G(IB) D FULL^VALM1 S Y=$$SEL()
- I $G(IB) S DIC("A")="CARE UNIT NAME: ",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,3)=+$G(IBINS)",DIC="^IBA(355.95," W ! D ^DIC K DIC
- I Y'>0 G CHGQ
- S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1))
- ; Edit fields outside of FM to assure uniqueness of combos is maintained
- W ! S DIR("A")="CARE UNIT NAME: ",DIR("B")=$P($G(^IBA(355.95,+IB95("IBCU"),0)),U),DIR(0)="355.95,.01AO",DIR("S")="I $P(^(0),U,3)=IBINS" D ^DIR K DIR
- I $D(DTOUT)!$D(DUOUT) G CHGQ
- I X="@" S DIR(0)="EA",DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE" D ^DIR K DIR G CHGQ
- I $P($G(^IBA(355.95,IB95("IBCU"),0)),U)'=Y S DIE="^IBA(355.95,",DR=".01///"_Y,DA=IB95("IBCU") D ^DIE ; File the name change
- S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE
- I $D(Y) G CHGQ
- ;
- I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ
- ; only 1 combination found for ins/care unit
- I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D
- . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0))
- ;
- ; Choose the combination to edit - more than 1 exists
- E D
- . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:"
- . S DIC="^IBA(355.96,",DIC(0)="EMQ",DIC("S")="I $D(^IBA(355.96,""ACARE"","_IB95("IBCU")_",Y))",X=IBINS D ^DIC K DIC S IBDA=+Y
- ;
- I IBDA>0 D
- . N IBDA0,Q,Q0
- . S IBDA0=$G(^IBA(355.96,IBDA,0))
- . Q:IBDA0=""
- . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***"
- . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0)
- . S Z=0 F S Z=$O(Q(Z)) Q:'Z W !,Q(Z)
- . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D")
- . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),!
- . W ! S DIR(0)="SA^E:EDIT;D:DELETE",DIR("B")="EDIT",DIR("A")="EDIT OR DELETE THIS CARE UNIT COMBINATION?: " D ^DIR K DIR
- . I $D(DTOUT)!$D(DUOUT) Q
- . I Y="D" D Q
- .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR
- .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK
- . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1
- . F Q:'IBEDIT S IBEDIT=0,IB0=$G(^IBA(355.96,+IBDA,0)) K IBZ F Z=.01,.03,.06,.04,.05 D Q:'IBOK!IBEDIT
- .. S Z100=Z*100
- .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q
- .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q
- .. I Z100=5 S IBCK=1
- .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0
- .. I '$P(IBZ(Z),U,2) D Q
- ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1
- ... S $P(IB0,U,Z100)=IBZ(Z)
- .. S (IBOK,IBCHG)=0
- .. I $P(IBZ(Z),U,2)=2 D
- ... S DIR(0)="YA",DIR("A",1)="This entry already exists",DIR("A")="Do you want to re-edit?: " W ! D ^DIR K DIR W !
- ... I Y=1 S (IBOK,IBEDIT)=1
- . I IBOK Q:'IBCHG S DIE="^IBA(355.96,",DR=".03////"_IBZ(.03)_";.04////"_IBZ(.04)_";.05////"_IBZ(.05)_";.06////"_IBZ(.06)_";.07",DA=+IBDA D ^DIE,BLD^IBCEP4 Q
- ;
- I '$G(IB) D BLD^IBCEP4
- CHGQ I '$G(IB) S VALMBCK="R"
- Q
- ;
- INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co
- ; IBINSZ = ien of ins co (file 36)
- ; IB95 = flag ("IBCU")=care unit
- ; can have subscripts to send in pre-entered data
- N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS
- S IBINS=IBINSZ
- S IBCHG=0,IBCU=$G(IB95("IBCU"))
- D FULL^VALM1
- I '$G(IBINSZ) K IB95 G INSQ
- W !
- F Z=.06,.04,.05,.07,.03 D G:Z="" INSQ
- . ;
- . I $S(Z=.04:'$D(IB95("IBFT")),Z=.05:'$D(IB95("IBCT")),Z=.06:'$D(IB95("IBPTYP")),Z=.03:'$D(IB95("IBCU")),1:1) D
- .. N DA
- .. K IBDICS
- .. I Z=.04 D
- ... I $P($G(^IBE(355.97,+$G(IB95("IBPTYP")),0)),U,3)="1A" S IBDICS="I Y'=1 K X",DIR("B")="UB-04",DIR("?")="ONLY UB-04 IS VALID FOR A BLUE CROSS ID"
- .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR
- . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q
- . ;
- . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q
- . ;
- . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q
- . ;
- . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q
- . ;
- . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q
- . ;
- . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D Q:Z=""
- .. N Q ; Assign from add care type
- .. S IBCT=0
- .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU"))
- .. S IB95("IBINS")=+IBINSZ
- .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D Q
- ... S DIR(0)="EA",DIR("A",1)="This combination already exists - NOT ADDED",DIR("A")="Press ENTER to continue" W ! D ^DIR K DIR W !
- .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))
- .. I Y<0 W ! S DIR("A",1)=" >> Care Unit NOT completely filed",DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR Q
- .. W ! S DIR(0)="EA",DIR("A",1)=" >> CARE UNIT COMBINATION FILED FOR THE INSURANCE CO",IBCT=1,IBCHG=1,DIR("A")="PRESS ENTER TO CONTINUE ",DIR(0)="EA" D ^DIR K DIR
- I $G(IBCHG) D BLD^IBCEP4
- INSQ S VALMBCK="R"
- Q
- ;
- EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96
- ; without direct Fileman call so uniqueness can be checked
- ; IBFLD = field # in file 355.96
- ; IB0 = current 0-node of data in the entry in file 355.96
- ; IBIEN = ien of entry being edited in file 355.96
- ; IBCK1 = flag ... if 1, checks for uniqueness after field changed
- ;
- ; FUNCTION RETURNS: value of field if field is OK, second piece is null
- ; If not good, 2nd piece = 1 : no data or ^ entered
- ; = 2 : record not unique
- N DIR,DA,Y,X,IBNEW,IBINS,IBVAL
- S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100)))
- S DIR(0)="355.96,"_IBFLD
- S:IBVAL'="" DIR("B")=IBVAL
- D ^DIR K DIR
- I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ
- S IBNEW=$P(Y,U)
- I $G(IBCK1) D
- . N X1,X2,X3,X4,X5
- . S X1=$S(IBFLD'=.03:IBINS,1:IBNEW),X2=$S(IBFLD'=.01:$P(IB0,U),1:IBNEW),X3=$S(IBFLD'=.04:$P(IB0,U,4),1:IBNEW),X4=$S(IBFLD'=.05:$P(IB0,U,5),1:IBNEW),X5=$S(IBFLD'=.06:$P(IB0,U,6),1:IBNEW)
- . I $S(X1=""!(X2="")!(X3="")!(X4="")!(X5=""):1,$O(^IBA(355.96,"AUNIQ",X1,X2,X3,X4,X5,0)):$O(^(0))'=IBIEN,1:0) S IBNEW=IBNEW_"^2"
- ;
- EDITQ Q IBNEW
- ;
- ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ; Add a new care unit record to file 355.96
- ; Same parameter definitions as EDIT
- N DIC,DA,X,Y,DLAYGO
- S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU
- D FILE^DICN
- Q Y
- ;
- DELETE(IB) ; delete a care unit name
- ; IB = 0 or null if called from list manager, 1 if not
- N DIR,X,Y
- I '$G(IB) D FULL^VALM1 S Y=$$SEL() I Y'>0 G DELETEQ
- S:'$G(IB) IB95("IBCU")=+Y
- S DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS",DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: ",DIR(0)="YA",DIR("B")="NO" D ^DIR K DIR
- I Y'=1 S IB95("IBCU")="" Q ; Changed their mind - don't delete
- S Z=0 F S Z=$O(^IBA(355.96,"B",IB95("IBCU"),Z)) Q:'Z S DIK="^IBA(355.96,",DA=Z D ^DIK
- S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK
- W ! S DIR(0)="EA",DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED",DIR("A")="PRESS ENTER TO CONTINUE " D ^DIR K DIR D BLD^IBCEP4
- DELETEQ ;
- S:'$G(IB) VALMBCK="R"
- Q
- ;
- SEL() ; Select entry from list
- ; returns ien in file 355.95 for selected entry
- N VALMY,SEL
- D EN^VALM2($G(XQORNOD(0)),"S")
- S SEL=+$O(VALMY(""))
- I SEL'>0 Q 0
- Q +$G(^TMP("IBPRV_CU",$J,"ZIDX",SEL))
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP4A 8777 printed Feb 18, 2025@23:38:01 Page 2
- IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
- +1 ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- NEW(IB) ; Add care unit
- +1 ; Assumes IBINS is defined as ins co ien (file 36)
- +2 ; IB = 0 or null if called from list manager, 1 if not
- +3 NEW DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK
- +4 IF '$GET(IB)
- DO FULL^VALM1
- +5 ;
- +6 ; Add an entry - either new care unit/ins co or a combination for
- +7 ; existing care unit/ins co
- +8 SET DIC("A")="SELECT CARE UNIT FOR THE INSURANCE CO: "
- SET DIC="^IBA(355.95,"
- SET DIC("S")="I $P(^(0),U,3)=+$G(IBINS)"
- SET DIC(0)="AELMQ"
- SET DIC("DR")=".03////"_+$GET(IBINS)_";.02"
- SET DLAYGO=355.95
- DO ^DIC
- KILL DIC,DLAYGO
- +9 if Y'>0
- GOTO NEWQ
- +10 SET IB95=3
- SET IB95("IBCU")=+Y
- +11 DO INSASS(IBINS,.IB95)
- +12 IF '$GET(IB)
- DO BLD^IBCEP4
- NEWQ IF '$GET(IB)
- SET VALMBCK="R"
- +1 QUIT
- +2 ;
- CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS
- +1 ; Assumes IBINS is defined as ins co ien (file 36)
- +2 ; IB = 0 or null if called from list manager, 1 if not
- +3 NEW DIC,DIK,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBOK,IBZ,IB0,IBEDIT,IBCK,IBDA,IBCHG,IBDELETE,Z100,DTOUT,DUOUT
- +4 IF '$GET(IB)
- DO FULL^VALM1
- SET Y=$$SEL()
- +5 IF $GET(IB)
- SET DIC("A")="CARE UNIT NAME: "
- SET DIC(0)="AEMQ"
- SET DIC("S")="I $P(^(0),U,3)=+$G(IBINS)"
- SET DIC="^IBA(355.95,"
- WRITE !
- DO ^DIC
- KILL DIC
- +6 IF Y'>0
- GOTO CHGQ
- +7 SET IB95("IBCU")=+Y
- SET IBDELETE=0
- SET IBDELETE(0)=$GET(^IBA(355.95,0))
- SET IBDELETE(1)=$GET(^(1))
- +8 ; Edit fields outside of FM to assure uniqueness of combos is maintained
- +9 WRITE !
- SET DIR("A")="CARE UNIT NAME: "
- SET DIR("B")=$PIECE($GET(^IBA(355.95,+IB95("IBCU"),0)),U)
- SET DIR(0)="355.95,.01AO"
- SET DIR("S")="I $P(^(0),U,3)=IBINS"
- DO ^DIR
- KILL DIR
- +10 IF $DATA(DTOUT)!$DATA(DUOUT)
- GOTO CHGQ
- +11 IF X="@"
- SET DIR(0)="EA"
- SET DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE"
- DO ^DIR
- KILL DIR
- GOTO CHGQ
- +12 ; File the name change
- IF $PIECE($GET(^IBA(355.95,IB95("IBCU"),0)),U)'=Y
- SET DIE="^IBA(355.95,"
- SET DR=".01///"_Y
- SET DA=IB95("IBCU")
- DO ^DIE
- +13 SET DR=".02"
- SET DIE="^IBA(355.95,"
- SET DA=IB95("IBCU")
- DO ^DIE
- +14 IF $DATA(Y)
- GOTO CHGQ
- +15 ;
- +16 IF $ORDER(^IBA(355.96,"ACARE",IB95("IBCU"),""))=""
- SET IB95=3
- DO INSASS(IBINS,.IB95)
- GOTO CHGQ
- +17 ; only 1 combination found for ins/care unit
- +18 IF $ORDER(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$ORDER(^IBA(355.96,"ACARE",IB95("IBCU"),0))
- Begin DoDot:1
- +19 SET IBDA=$ORDER(^IBA(355.96,"ACARE",IB95("IBCU"),0))
- End DoDot:1
- +20 ;
- +21 ; Choose the combination to edit - more than 1 exists
- +22 IF '$TEST
- Begin DoDot:1
- +23 WRITE !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:"
- +24 SET DIC="^IBA(355.96,"
- SET DIC(0)="EMQ"
- SET DIC("S")="I $D(^IBA(355.96,""ACARE"","_IB95("IBCU")_",Y))"
- SET X=IBINS
- DO ^DIC
- KILL DIC
- SET IBDA=+Y
- End DoDot:1
- +25 ;
- +26 IF IBDA>0
- Begin DoDot:1
- +27 NEW IBDA0,Q,Q0
- +28 SET IBDA0=$GET(^IBA(355.96,IBDA,0))
- +29 if IBDA0=""
- QUIT
- +30 WRITE !!,"*** CARE UNIT COMBINATION FOR: ",$PIECE($GET(^IBA(355.95,+IB95("IBCU"),0)),U)," ***"
- +31 DO DISP^IBCEP4("Q",IBINS,$PIECE(IBDA0,U,6),$PIECE(IBDA0,U,4),$PIECE(IBDA0,U,5),1,.Q0)
- +32 SET Z=0
- FOR
- SET Z=$ORDER(Q(Z))
- if 'Z
- QUIT
- WRITE !,Q(Z)
- +33 IF $PIECE(IBDA0,U,7)
- WRITE !,"EXP DATE: ",$$FMTE^XLFDT($PIECE(IBDA0,U,7),"2D")
- +34 WRITE !,"CARE UNIT: ",$PIECE($GET(^IBA(355.95,+IBDA0,0)),U),!
- +35 WRITE !
- SET DIR(0)="SA^E:EDIT;D:DELETE"
- SET DIR("B")="EDIT"
- SET DIR("A")="EDIT OR DELETE THIS CARE UNIT COMBINATION?: "
- DO ^DIR
- KILL DIR
- +36 IF $DATA(DTOUT)!$DATA(DUOUT)
- QUIT
- +37 IF Y="D"
- Begin DoDot:2
- +38 SET DIR(0)="YA"
- SET DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: "
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- +39 IF Y=1
- SET DIK="^IBA(355.96,"
- SET DA=IBDA
- SET IBCHG=1
- DO ^DIK
- End DoDot:2
- QUIT
- +40 SET (IBCK,IBCHG)=0
- SET (IBEDIT,IBOK)=1
- +41 FOR
- if 'IBEDIT
- QUIT
- SET IBEDIT=0
- SET IB0=$GET(^IBA(355.96,+IBDA,0))
- KILL IBZ
- FOR Z=.01,.03,.06,.04,.05
- Begin DoDot:2
- +42 SET Z100=Z*100
- +43 IF Z100=1
- WRITE !,"CARE UNIT: ",$PIECE($GET(^IBA(355.95,IB95("IBCU"),0)),U)
- SET IBZ(.01)=$PIECE(IB0,U)
- QUIT
- +44 IF Z100=3
- WRITE !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$PIECE(IB0,U,3))
- SET IBZ(.03)=$PIECE(IB0,U)
- QUIT
- +45 IF Z100=5
- SET IBCK=1
- +46 SET IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK)
- SET IBCK=0
- +47 IF '$PIECE(IBZ(Z),U,2)
- Begin DoDot:3
- +48 IF $PIECE(IB0,U,Z100)'=IBZ(Z)
- SET IBCHG=1
- +49 SET $PIECE(IB0,U,Z100)=IBZ(Z)
- End DoDot:3
- QUIT
- +50 SET (IBOK,IBCHG)=0
- +51 IF $PIECE(IBZ(Z),U,2)=2
- Begin DoDot:3
- +52 SET DIR(0)="YA"
- SET DIR("A",1)="This entry already exists"
- SET DIR("A")="Do you want to re-edit?: "
- WRITE !
- DO ^DIR
- KILL DIR
- WRITE !
- +53 IF Y=1
- SET (IBOK,IBEDIT)=1
- End DoDot:3
- End DoDot:2
- if 'IBOK!IBEDIT
- QUIT
- +54 IF IBOK
- if 'IBCHG
- QUIT
- SET DIE="^IBA(355.96,"
- SET DR=".03////"_IBZ(.03)_";.04////"_IBZ(.04)_";.05////"_IBZ(.05)_";.06////"_IBZ(.06)_";.07"
- SET DA=+IBDA
- DO ^DIE
- DO BLD^IBCEP4
- QUIT
- End DoDot:1
- +55 ;
- +56 IF '$GET(IB)
- DO BLD^IBCEP4
- CHGQ IF '$GET(IB)
- SET VALMBCK="R"
- +1 QUIT
- +2 ;
- INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co
- +1 ; IBINSZ = ien of ins co (file 36)
- +2 ; IB95 = flag ("IBCU")=care unit
- +3 ; can have subscripts to send in pre-entered data
- +4 NEW DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS
- +5 SET IBINS=IBINSZ
- +6 SET IBCHG=0
- SET IBCU=$GET(IB95("IBCU"))
- +7 DO FULL^VALM1
- +8 IF '$GET(IBINSZ)
- KILL IB95
- GOTO INSQ
- +9 WRITE !
- +10 FOR Z=.06,.04,.05,.07,.03
- Begin DoDot:1
- +11 ;
- +12 IF $SELECT(Z=.04:'$DATA(IB95("IBFT")),Z=.05:'$DATA(IB95("IBCT")),Z=.06:'$DATA(IB95("IBPTYP")),Z=.03:'$DATA(IB95("IBCU")),1:1)
- Begin DoDot:2
- +13 NEW DA
- +14 KILL IBDICS
- +15 IF Z=.04
- Begin DoDot:3
- +16 IF $PIECE($GET(^IBE(355.97,+$GET(IB95("IBPTYP")),0)),U,3)="1A"
- SET IBDICS="I Y'=1 K X"
- SET DIR("B")="UB-04"
- SET DIR("?")="ONLY UB-04 IS VALID FOR A BLUE CROSS ID"
- End DoDot:3
- +17 SET DIR(0)="355.96,"_Z_$SELECT($GET(IBDICS)="":"",1:"^^"_IBDICS)
- DO ^DIR
- KILL DIR
- End DoDot:2
- +18 IF $DATA(DTOUT)!$DATA(DUOUT)
- SET VALMBCK="R"
- SET Z=""
- if $GET(IB95)=2
- KILL IB95
- QUIT
- +19 ;
- +20 IF Z=.04
- SET IBFT=$SELECT($GET(IB95("IBFT"))="":+Y,1:IB95("IBFT"))
- SET IB95("IBFT")=IBFT
- QUIT
- +21 ;
- +22 IF Z=.05
- SET IBCT=$SELECT($GET(IB95("IBCT"))="":+Y,1:IB95("IBCT"))
- SET IB95("IBCT")=IBCT
- QUIT
- +23 ;
- +24 IF Z=.06
- SET IBPTYP=$SELECT($GET(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP"))
- SET IB95("IBPTYP")=IBPTYP
- QUIT
- +25 ;
- +26 IF Z=.07
- SET IBPXDT=$SELECT('$GET(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT"))
- SET IB95("IBEXPDT")=IBPXDT
- QUIT
- +27 ;
- +28 IF Z=.03
- IF $GET(IB95)=3
- IF $GET(IB95("IBCU"))'=""
- Begin DoDot:2
- +29 ; Assign from add care type
- NEW Q
- +30 SET IBCT=0
- +31 WRITE !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU"))
- +32 SET IB95("IBINS")=+IBINSZ
- +33 IF $DATA(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP")))
- Begin DoDot:3
- +34 SET DIR(0)="EA"
- SET DIR("A",1)="This combination already exists - NOT ADDED"
- SET DIR("A")="Press ENTER to continue"
- WRITE !
- DO ^DIR
- KILL DIR
- WRITE !
- End DoDot:3
- QUIT
- +35 SET IBCT=1
- SET Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))
- +36 IF Y<0
- WRITE !
- SET DIR("A",1)=" >> Care Unit NOT completely filed"
- SET DIR("A")="PRESS ENTER TO CONTINUE "
- SET DIR(0)="EA"
- DO ^DIR
- KILL DIR
- QUIT
- +37 WRITE !
- SET DIR(0)="EA"
- SET DIR("A",1)=" >> CARE UNIT COMBINATION FILED FOR THE INSURANCE CO"
- SET IBCT=1
- SET IBCHG=1
- SET DIR("A")="PRESS ENTER TO CONTINUE "
- SET DIR(0)="EA"
- DO ^DIR
- KILL DIR
- End DoDot:2
- if Z=""
- QUIT
- End DoDot:1
- if Z=""
- GOTO INSQ
- +38 IF $GET(IBCHG)
- DO BLD^IBCEP4
- INSQ SET VALMBCK="R"
- +1 QUIT
- +2 ;
- EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96
- +1 ; without direct Fileman call so uniqueness can be checked
- +2 ; IBFLD = field # in file 355.96
- +3 ; IB0 = current 0-node of data in the entry in file 355.96
- +4 ; IBIEN = ien of entry being edited in file 355.96
- +5 ; IBCK1 = flag ... if 1, checks for uniqueness after field changed
- +6 ;
- +7 ; FUNCTION RETURNS: value of field if field is OK, second piece is null
- +8 ; If not good, 2nd piece = 1 : no data or ^ entered
- +9 ; = 2 : record not unique
- +10 NEW DIR,DA,Y,X,IBNEW,IBINS,IBVAL
- +11 SET IBINS=+IB0
- SET IBNEW=""
- SET IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$PIECE(IB0,U,(IBFLD*100)))
- +12 SET DIR(0)="355.96,"_IBFLD
- +13 if IBVAL'=""
- SET DIR("B")=IBVAL
- +14 DO ^DIR
- KILL DIR
- +15 IF Y=""!$DATA(DTOUT)!$DATA(DUOUT)
- SET IBNEW="^1"
- GOTO EDITQ
- +16 SET IBNEW=$PIECE(Y,U)
- +17 IF $GET(IBCK1)
- Begin DoDot:1
- +18 NEW X1,X2,X3,X4,X5
- +19 SET X1=$SELECT(IBFLD'=.03:IBINS,1:IBNEW)
- SET X2=$SELECT(IBFLD'=.01:$PIECE(IB0,U),1:IBNEW)
- SET X3=$SELECT(IBFLD'=.04:$PIECE(IB0,U,4),1:IBNEW)
- SET X4=$SELECT(IBFLD'=.05:$PIECE(IB0,U,5),1:IBNEW)
- SET X5=$SELECT(IBFLD'=.06:$PIECE(IB0,U,6),1:IBNEW)
- +20 IF $SELECT(X1=""!(X2="")!(X3="")!(X4="")!(X5=""):1,$ORDER(^IBA(355.96,"AUNIQ",X1,X2,X3,X4,X5,0)):$ORDER(^(0))'=IBIEN,1:0)
- SET IBNEW=IBNEW_"^2"
- End DoDot:1
- +21 ;
- EDITQ QUIT IBNEW
- +1 ;
- ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ; Add a new care unit record to file 355.96
- +1 ; Same parameter definitions as EDIT
- +2 NEW DIC,DA,X,Y,DLAYGO
- +3 SET DIC(0)="L"
- SET DLAYGO=355.96
- SET DIC="^IBA(355.96,"
- SET DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP
- SET X=IBCU
- +4 DO FILE^DICN
- +5 QUIT Y
- +6 ;
- DELETE(IB) ; delete a care unit name
- +1 ; IB = 0 or null if called from list manager, 1 if not
- +2 NEW DIR,X,Y
- +3 IF '$GET(IB)
- DO FULL^VALM1
- SET Y=$$SEL()
- IF Y'>0
- GOTO DELETEQ
- +4 if '$GET(IB)
- SET IB95("IBCU")=+Y
- +5 SET DIR("A",1)="THIS WILL DELETE THE CARE UNIT NAME AND ALL ITS COMBINATIONS"
- SET DIR("A")="ARE YOU SURE THIS IS WHAT YOU WANT TO DO?: "
- SET DIR(0)="YA"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- +6 ; Changed their mind - don't delete
- IF Y'=1
- SET IB95("IBCU")=""
- QUIT
- +7 SET Z=0
- FOR
- SET Z=$ORDER(^IBA(355.96,"B",IB95("IBCU"),Z))
- if 'Z
- QUIT
- SET DIK="^IBA(355.96,"
- SET DA=Z
- DO ^DIK
- +8 SET DA=IB95("IBCU")
- SET DIK="^IBA(355.95,"
- DO ^DIK
- +9 WRITE !
- SET DIR(0)="EA"
- SET DIR("A",1)="CARE UNIT AND ALL ITS COMBINATIONS WERE DELETED"
- SET DIR("A")="PRESS ENTER TO CONTINUE "
- DO ^DIR
- KILL DIR
- DO BLD^IBCEP4
- DELETEQ ;
- +1 if '$GET(IB)
- SET VALMBCK="R"
- +2 QUIT
- +3 ;
- SEL() ; Select entry from list
- +1 ; returns ien in file 355.95 for selected entry
- +2 NEW VALMY,SEL
- +3 DO EN^VALM2($GET(XQORNOD(0)),"S")
- +4 SET SEL=+$ORDER(VALMY(""))
- +5 IF SEL'>0
- QUIT 0
- +6 QUIT +$GET(^TMP("IBPRV_CU",$JOB,"ZIDX",SEL))
- +7 ;