- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCEP4A.m
r613 r623 1 IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 2 ;;2.0;INTEGRATED BILLING;**137,232,280,349,377**;21-MAR-94;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 NEW(IB) ; Add care unit 6 ; Assumes IBINS is defined as ins co ien (file 36) 7 ; IB = 0 or null if called from list manager, 1 if not 8 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK 9 I '$G(IB) D FULL^VALM1 10 ; 11 ; Add an entry - either new care unit/ins co or a combination for 12 ; existing care unit/ins co 13 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 14 G:Y'>0 NEWQ 15 S IB95=3,IB95("IBCU")=+Y 16 D INSASS(IBINS,.IB95) 17 I '$G(IB) D BLD^IBCEP4 18 NEWQ I '$G(IB) S VALMBCK="R" 19 Q 20 ; 21 CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS 22 ; Assumes IBINS is defined as ins co ien (file 36) 23 ; IB = 0 or null if called from list manager, 1 if not 24 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 25 I '$G(IB) D FULL^VALM1 S Y=$$SEL() 26 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 27 I Y'>0 G CHGQ 28 S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1)) 29 ; Edit fields outside of FM to assure uniqueness of combos is maintained 30 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 31 I $D(DTOUT)!$D(DUOUT) G CHGQ 32 I X="@" S DIR(0)="EA",DIR("A")="NOTHING DELETED - PRESS ENTER TO CONTINUE" D ^DIR K DIR G CHGQ 33 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 34 S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE 35 I $D(Y) G CHGQ 36 ; 37 I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ 38 ; only 1 combination found for ins/care unit 39 I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D 40 . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) 41 ; 42 ; Choose the combination to edit - more than 1 exists 43 E D 44 . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:" 45 . 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 46 ; 47 I IBDA>0 D 48 . N IBDA0,Q,Q0 49 . S IBDA0=$G(^IBA(355.96,IBDA,0)) 50 . Q:IBDA0="" 51 . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***" 52 . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0) 53 . S Z=0 F S Z=$O(Q(Z)) Q:'Z W !,Q(Z) 54 . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D") 55 . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),! 56 . 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 57 . I $D(DTOUT)!$D(DUOUT) Q 58 . I Y="D" D Q 59 .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR 60 .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK 61 . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1 62 . 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 63 .. S Z100=Z*100 64 .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q 65 .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q 66 .. I Z100=5 S IBCK=1 67 .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0 68 .. I '$P(IBZ(Z),U,2) D Q 69 ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1 70 ... S $P(IB0,U,Z100)=IBZ(Z) 71 .. S (IBOK,IBCHG)=0 72 .. I $P(IBZ(Z),U,2)=2 D 73 ... 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 ! 74 ... I Y=1 S (IBOK,IBEDIT)=1 75 . 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 76 ; 77 I '$G(IB) D BLD^IBCEP4 78 CHGQ I '$G(IB) S VALMBCK="R" 79 Q 80 ; 81 INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co 82 ; IBINSZ = ien of ins co (file 36) 83 ; IB95 = flag ("IBCU")=care unit 84 ; can have subscripts to send in pre-entered data 85 N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS 86 S IBINS=IBINSZ 87 S IBCHG=0,IBCU=$G(IB95("IBCU")) 88 D FULL^VALM1 89 I '$G(IBINSZ) K IB95 G INSQ 90 W ! 91 F Z=.06,.04,.05,.07,.03 D G:Z="" INSQ 92 . ; 93 . 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 94 .. N DA 95 .. K IBDICS 96 .. I Z=.04 D 97 ... 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" 98 .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR 99 . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q 100 . ; 101 . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q 102 . ; 103 . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q 104 . ; 105 . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q 106 . ; 107 . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q 108 . ; 109 . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D Q:Z="" 110 .. N Q ; Assign from add care type 111 .. S IBCT=0 112 .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU")) 113 .. S IB95("IBINS")=+IBINSZ 114 .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D Q 115 ... 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 ! 116 .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP")) 117 .. 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 118 .. 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 119 I $G(IBCHG) D BLD^IBCEP4 120 INSQ S VALMBCK="R" 121 Q 122 ; 123 EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96 124 ; without direct Fileman call so uniqueness can be checked 125 ; IBFLD = field # in file 355.96 126 ; IB0 = current 0-node of data in the entry in file 355.96 127 ; IBIEN = ien of entry being edited in file 355.96 128 ; IBCK1 = flag ... if 1, checks for uniqueness after field changed 129 ; 130 ; FUNCTION RETURNS: value of field if field is OK, second piece is null 131 ; If not good, 2nd piece = 1 : no data or ^ entered 132 ; = 2 : record not unique 133 N DIR,DA,Y,X,IBNEW,IBINS,IBVAL 134 S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100))) 135 S DIR(0)="355.96,"_IBFLD 136 S:IBVAL'="" DIR("B")=IBVAL 137 D ^DIR K DIR 138 I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ 139 S IBNEW=$P(Y,U) 140 I $G(IBCK1) D 141 . N X1,X2,X3,X4,X5 142 . 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) 143 . 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" 144 ; 145 EDITQ Q IBNEW 146 ; 147 ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ; Add a new care unit record to file 355.96 148 ; Same parameter definitions as EDIT 149 N DIC,DA,X,Y,DLAYGO 150 S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU 151 D FILE^DICN 152 Q Y 153 ; 154 DELETE(IB) ; delete a care unit name 155 ; IB = 0 or null if called from list manager, 1 if not 156 N DIR,X,Y 157 I '$G(IB) D FULL^VALM1 S Y=$$SEL() I Y'>0 G DELETEQ 158 S:'$G(IB) IB95("IBCU")=+Y 159 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 160 I Y'=1 S IB95("IBCU")="" Q ; Changed their mind - don't delete 161 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 162 S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK 163 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 164 DELETEQ ; 165 S:'$G(IB) VALMBCK="R" 166 Q 167 ; 168 SEL() ; Select entry from list 169 ; returns ien in file 355.95 for selected entry 170 N VALMY,SEL 171 D EN^VALM2($G(XQORNOD(0)),"S") 172 S SEL=+$O(VALMY("")) 173 I SEL'>0 Q 0 174 Q +$G(^TMP("IBPRV_CU",$J,"ZIDX",SEL)) 175 ; 1 IBCEP4A ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 2 ;;2.0;INTEGRATED BILLING;**137,232,280,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 NEW(IB) ; Add care unit 6 ; Assumes IBINS is defined as ins co ien (file 36) 7 ; IB = 0 or null if called from list manager, 1 if not 8 N DIC,DIR,X,Y,Z,DA,DR,DIE,DO,DD,DLAYGO,IB95,IBADD,IBOK 9 I '$G(IB) D FULL^VALM1 10 ; 11 ; Add an entry - either new care unit/ins co or a combination for 12 ; existing care unit/ins co 13 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 14 G:Y'>0 NEWQ 15 S IB95=3,IB95("IBCU")=+Y 16 D INSASS(IBINS,.IB95) 17 I '$G(IB) D BLD^IBCEP4 18 NEWQ I '$G(IB) S VALMBCK="R" 19 Q 20 ; 21 CHANGE(IB) ; Edit a care unit name or combination for ins co IBINS 22 ; Assumes IBINS is defined as ins co ien (file 36) 23 ; IB = 0 or null if called from list manager, 1 if not 24 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 25 I '$G(IB) D FULL^VALM1 26 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 27 I Y'>0 G CHGQ 28 S IB95("IBCU")=+Y,IBDELETE=0,IBDELETE(0)=$G(^IBA(355.95,0)),IBDELETE(1)=$G(^(1)) 29 ; Edit fields outside of FM to assure uniqueness of combos is maintained 30 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 31 I $D(DTOUT)!$D(DUOUT) G CHGQ 32 ; 33 ; Care unit name was deleted 34 I X="@" D G CHGQ 35 . 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 36 . I Y'=1 S IB95("IBCU")="" Q ; Changed their mind - don't delete 37 . 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 38 . S DA=IB95("IBCU"),DIK="^IBA(355.95," D ^DIK 39 . 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 40 ; 41 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 42 S DR=".02",DIE="^IBA(355.95,",DA=IB95("IBCU") D ^DIE 43 I $D(Y) G CHGQ 44 ; 45 I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""))="" S IB95=3 D INSASS(IBINS,.IB95) G CHGQ 46 ; only 1 combination found for ins/care unit 47 I $O(^IBA(355.96,"ACARE",IB95("IBCU"),""),-1)=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) D 48 . S IBDA=$O(^IBA(355.96,"ACARE",IB95("IBCU"),0)) 49 ; 50 ; Choose the combination to edit - more than 1 exists 51 E D 52 . W !,"SELECT ONE OF THE FOLLOWING CARE UNIT COMBINATIONS:" 53 . 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 54 ; 55 I IBDA>0 D 56 . N IBDA0,Q,Q0 57 . S IBDA0=$G(^IBA(355.96,IBDA,0)) 58 . Q:IBDA0="" 59 . W !!,"*** CARE UNIT COMBINATION FOR: ",$P($G(^IBA(355.95,+IB95("IBCU"),0)),U)," ***" 60 . D DISP^IBCEP4("Q",IBINS,$P(IBDA0,U,6),$P(IBDA0,U,4),$P(IBDA0,U,5),1,.Q0) 61 . S Z=0 F S Z=$O(Q(Z)) Q:'Z W !,Q(Z) 62 . I $P(IBDA0,U,7) W !,"EXP DATE: ",$$FMTE^XLFDT($P(IBDA0,U,7),"2D") 63 . W !,"CARE UNIT: ",$P($G(^IBA(355.95,+IBDA0,0)),U),! 64 . 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 65 . I $D(DTOUT)!$D(DUOUT) Q 66 . I Y="D" D Q 67 .. S DIR(0)="YA",DIR("A")="ARE YOU SURE YOU WANT TO DELETE THIS CARE UNIT COMBINATION?: ",DIR("B")="NO" D ^DIR K DIR 68 .. I Y=1 S DIK="^IBA(355.96,",DA=IBDA,IBCHG=1 D ^DIK 69 . S (IBCK,IBCHG)=0,(IBEDIT,IBOK)=1 70 . 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 71 .. S Z100=Z*100 72 .. I Z100=1 W !,"CARE UNIT: ",$P($G(^IBA(355.95,IB95("IBCU"),0)),U) S IBZ(.01)=$P(IB0,U) Q 73 .. I Z100=3 W !,"INSURANCE COMPANY: ",$$EXPAND^IBTRE(355.96,.03,$P(IB0,U,3)) S IBZ(.03)=$P(IB0,U) Q 74 .. I Z100=5 S IBCK=1 75 .. S IBZ(Z)=$$EDIT(Z,IB0,+IBDA,IBCK),IBCK=0 76 .. I '$P(IBZ(Z),U,2) D Q 77 ... I $P(IB0,U,Z100)'=IBZ(Z) S IBCHG=1 78 ... S $P(IB0,U,Z100)=IBZ(Z) 79 .. S (IBOK,IBCHG)=0 80 .. I $P(IBZ(Z),U,2)=2 D 81 ... 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 ! 82 ... I Y=1 S (IBOK,IBEDIT)=1 83 . 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 84 ; 85 I '$G(IB) D BLD^IBCEP4 86 CHGQ I '$G(IB) S VALMBCK="R" 87 Q 88 ; 89 INSASS(IBINSZ,IB95) ; Assign care unit to or delete from an ins co 90 ; IBINSZ = ien of ins co (file 36) 91 ; IB95 = flag ("IBCU")=care unit 92 ; can have subscripts to send in pre-entered data 93 N DIR,DIC,DA,DR,X,Y,Z,IBFT,IBCT,IBPTYP,IBCU,IBCHG,IBINS,IBDA,IBPXDT,IBDICS 94 S IBINS=IBINSZ 95 S IBCHG=0,IBCU=$G(IB95("IBCU")) 96 D FULL^VALM1 97 I '$G(IBINSZ) K IB95 G INSQ 98 W ! 99 F Z=.06,.04,.05,.07,.03 D G:Z="" INSQ 100 . ; 101 . 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 102 .. N DA 103 .. K IBDICS 104 .. I Z=.04 D 105 ... 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" 106 .. S DIR(0)="355.96,"_Z_$S($G(IBDICS)="":"",1:"^^"_IBDICS) D ^DIR K DIR 107 . I $D(DTOUT)!$D(DUOUT) S VALMBCK="R",Z="" K:$G(IB95)=2 IB95 Q 108 . ; 109 . I Z=.04 S IBFT=$S($G(IB95("IBFT"))="":+Y,1:IB95("IBFT")) S IB95("IBFT")=IBFT Q 110 . ; 111 . I Z=.05 S IBCT=$S($G(IB95("IBCT"))="":+Y,1:IB95("IBCT")) S IB95("IBCT")=IBCT Q 112 . ; 113 . I Z=.06 S IBPTYP=$S($G(IB95("IBPTYP"))="":+Y,1:IB95("IBPTYP")) S IB95("IBPTYP")=IBPTYP Q 114 . ; 115 . I Z=.07 S IBPXDT=$S('$G(IB95("IBEXPDT")):+Y,1:IB95("IBEXPDT")) S IB95("IBEXPDT")=IBPXDT Q 116 . ; 117 . I Z=.03,$G(IB95)=3,$G(IB95("IBCU"))'="" D Q:Z="" 118 .. N Q ; Assign from add care type 119 .. S IBCT=0 120 .. W !,"CARE UNIT: "_$$EXPAND^IBTRE(355.96,.01,IB95("IBCU")) 121 .. S IB95("IBINS")=+IBINSZ 122 .. I $D(^IBA(355.96,"AUNIQ",IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP"))) D Q 123 ... 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 ! 124 .. S IBCT=1 S Y=$$ADDCU(IBINSZ,IB95("IBCU"),IB95("IBFT"),IB95("IBCT"),IB95("IBPTYP")) 125 .. 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 126 .. 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 127 I $G(IBCHG) D BLD^IBCEP4 128 INSQ S VALMBCK="R" 129 Q 130 ; 131 EDIT(IBFLD,IB0,IBIEN,IBCK1) ; Allow addition/edit of fields in file 355.96 132 ; without direct Fileman call so uniqueness can be checked 133 ; IBFLD = field # in file 355.96 134 ; IB0 = current 0-node of data in the entry in file 355.96 135 ; IBIEN = ien of entry being edited in file 355.96 136 ; IBCK1 = flag ... if 1, checks for uniqueness after field changed 137 ; 138 ; FUNCTION RETURNS: value of field if field is OK, second piece is null 139 ; If not good, 2nd piece = 1 : no data or ^ entered 140 ; = 2 : record not unique 141 N DIR,DA,Y,X,IBNEW,IBINS,IBVAL 142 S IBINS=+IB0,IBNEW="",IBVAL=$$EXPAND^IBTRE(355.96,IBFLD,$P(IB0,U,(IBFLD*100))) 143 S DIR(0)="355.96,"_IBFLD 144 S:IBVAL'="" DIR("B")=IBVAL 145 D ^DIR K DIR 146 I Y=""!$D(DTOUT)!$D(DUOUT) S IBNEW="^1" G EDITQ 147 S IBNEW=$P(Y,U) 148 I $G(IBCK1) D 149 . N X1,X2,X3,X4,X5 150 . 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) 151 . 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" 152 ; 153 EDITQ Q IBNEW 154 ; 155 ADDCU(IBINSZ,IBCU,IBFT,IBCT,IBPTYP) ; Add a new care unit record to file 355.96 156 ; Same parameter definitions as EDIT 157 N DIC,DA,X,Y,DLAYGO 158 S DIC(0)="L",DLAYGO=355.96,DIC="^IBA(355.96,",DIC("DR")=".03////"_IBINSZ_";.04////"_IBFT_";.05////"_IBCT_";.06////"_IBPTYP,X=IBCU 159 D FILE^DICN 160 Q Y 161 ;
Note:
See TracChangeset
for help on using the changeset viewer.
