| [613] | 1 | IB20P338 ;ALB/CXW - IB*2.0*338 POST INIT: MCCR UTILITY CODES (#399.1) ; 1/20/06
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**338**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | POST ;
|
|---|
| 6 | N U S U="^"
|
|---|
| 7 | D START,MUCODES,END
|
|---|
| 8 | Q
|
|---|
| 9 | START ;
|
|---|
| 10 | D MES^XPDUTL("")
|
|---|
| 11 | D MES^XPDUTL(" IB*2.0*338 Post-Install .....")
|
|---|
| 12 | Q
|
|---|
| 13 | END ;
|
|---|
| 14 | D MES^XPDUTL("")
|
|---|
| 15 | D MES^XPDUTL(" IB*2.0*338 Post-Install Complete")
|
|---|
| 16 | Q
|
|---|
| 17 | ;
|
|---|
| 18 | MUCODES ; Add MCCR UTILITY Codes to 399.1
|
|---|
| 19 | N DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBFN,IBTYPE
|
|---|
| 20 | S IBCNT=0,IBTYPE="UB-92 Value Codes"
|
|---|
| 21 | ;
|
|---|
| 22 | F IBI=1:1 S IBLN=$P($T(MUCF+IBI),";;",2) Q:IBLN="" I $E(IBLN)'=" " D
|
|---|
| 23 | . ;
|
|---|
| 24 | . I $P(IBLN,U,1)="" Q ;if no code enters quit
|
|---|
| 25 | . ;
|
|---|
| 26 | . I +$$MCCRUTL($P(IBLN,U,3),+IBLN) D Q ; if code exists quit
|
|---|
| 27 | . . D BMES^XPDUTL(" Duplication of "_IBTYPE_": "_$P(IBLN,U,3))
|
|---|
| 28 | . ;
|
|---|
| 29 | . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=$E($P(IBLN,U,8),1,60) D FILE^DICN K DIC I Y<1 K X,Y Q
|
|---|
| 30 | . S IBFN=+Y,IBCNT=IBCNT+1
|
|---|
| 31 | . ;
|
|---|
| 32 | . S DR=".02////"_$P(IBLN,U,3)_";"_$P(IBLN,U,2)_"////"_1
|
|---|
| 33 | . S DR=DR_$S($P(IBLN,U,4)'="":";.03////"_$P(IBLN,U,4),1:"")_$S($P(IBLN,U,5)'="":";.16////"_$P(IBLN,U,5),1:"")
|
|---|
| 34 | . S DR=DR_$S($P(IBLN,U,6)'="":";.17////"_$P(IBLN,U,6),1:"")_$S($P(IBLN,U,7)'="":";.19////"_$P(IBLN,U,7),1:"")
|
|---|
| 35 | . ;
|
|---|
| 36 | . S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
|
|---|
| 37 | ;
|
|---|
| 38 | MSG ;add message to install giving count and type of codes added
|
|---|
| 39 | D BMES^XPDUTL(" "_IBCNT_" "_IBTYPE_" added to file (#399.1)")
|
|---|
| 40 | Q
|
|---|
| 41 | ;
|
|---|
| 42 | MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true
|
|---|
| 43 | ;
|
|---|
| 44 | N IBX,IBY S IBY=""
|
|---|
| 45 | I $G(X)'="" S IBX=0 F S IBX=$O(^DGCR(399.1,"C",X,IBX)) Q:'IBX I $P($G(^DGCR(399.1,IBX,0)),U,+$G(P)) S IBY=IBX
|
|---|
| 46 | Q IBY
|
|---|
| 47 | ;
|
|---|
| 48 | ;
|
|---|
| 49 | MUCF ; TYPE #^TYPE FLD^.02 CODE ^.03 ABBR^.16 OCC REL^.17 OCC SPAN^.19 VC AMNT^.01 NAME
|
|---|
| 50 | ;;
|
|---|
| 51 | ;;^UB-92 Value Codes
|
|---|
| 52 | ;;11^.18^A0^^^^^SPECIAL ZIP CODE REPORTING
|
|---|
| 53 | ;;
|
|---|
