IB20P338 ;ALB/CXW - IB*2.0*338 POST INIT: MCCR UTILITY CODES (#399.1) ; 1/20/06
;;2.0;INTEGRATED BILLING;**338**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
POST ;
N U S U="^"
D START,MUCODES,END
Q
START ;
D MES^XPDUTL("")
D MES^XPDUTL(" IB*2.0*338 Post-Install .....")
Q
END ;
D MES^XPDUTL("")
D MES^XPDUTL(" IB*2.0*338 Post-Install Complete")
Q
;
MUCODES ; Add MCCR UTILITY Codes to 399.1
N DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBFN,IBTYPE
S IBCNT=0,IBTYPE="UB-92 Value Codes"
;
F IBI=1:1 S IBLN=$P($T(MUCF+IBI),";;",2) Q:IBLN="" I $E(IBLN)'=" " D
. ;
. I $P(IBLN,U,1)="" Q ;if no code enters quit
. ;
. I +$$MCCRUTL($P(IBLN,U,3),+IBLN) D Q ; if code exists quit
. . D BMES^XPDUTL(" Duplication of "_IBTYPE_": "_$P(IBLN,U,3))
. ;
. 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
. S IBFN=+Y,IBCNT=IBCNT+1
. ;
. S DR=".02////"_$P(IBLN,U,3)_";"_$P(IBLN,U,2)_"////"_1
. 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:"")
. 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:"")
. ;
. S DIE="^DGCR(399.1,",DA=+IBFN D ^DIE K DIE,DA,DR,X,Y
;
MSG ;add message to install giving count and type of codes added
D BMES^XPDUTL(" "_IBCNT_" "_IBTYPE_" added to file (#399.1)")
Q
;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true
;
N IBX,IBY S IBY=""
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
Q IBY
;
;
MUCF ; TYPE #^TYPE FLD^.02 CODE ^.03 ABBR^.16 OCC REL^.17 OCC SPAN^.19 VC AMNT^.01 NAME
;;
;;^UB-92 Value Codes
;;11^.18^A0^^^^^SPECIAL ZIP CODE REPORTING
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P338 1884 printed Apr 09, 2024@21:14:56 Page 2
IB20P338 ;ALB/CXW - IB*2.0*338 POST INIT: MCCR UTILITY CODES (#399.1) ; 1/20/06
+1 ;;2.0;INTEGRATED BILLING;**338**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
POST ;
+1 NEW U
SET U="^"
+2 DO START
DO MUCODES
DO END
+3 QUIT
START ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" IB*2.0*338 Post-Install .....")
+3 QUIT
END ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" IB*2.0*338 Post-Install Complete")
+3 QUIT
+4 ;
MUCODES ; Add MCCR UTILITY Codes to 399.1
+1 NEW DLAYGO,DIC,DIE,DD,DO,DA,DR,X,Y,IBA,IBI,IBLN,IBCNT,IBFN,IBTYPE
+2 SET IBCNT=0
SET IBTYPE="UB-92 Value Codes"
+3 ;
+4 FOR IBI=1:1
SET IBLN=$PIECE($TEXT(MUCF+IBI),";;",2)
if IBLN=""
QUIT
IF $EXTRACT(IBLN)'=" "
Begin DoDot:1
+5 ;
+6 ;if no code enters quit
IF $PIECE(IBLN,U,1)=""
QUIT
+7 ;
+8 ; if code exists quit
IF +$$MCCRUTL($PIECE(IBLN,U,3),+IBLN)
Begin DoDot:2
+9 DO BMES^XPDUTL(" Duplication of "_IBTYPE_": "_$PIECE(IBLN,U,3))
End DoDot:2
QUIT
+10 ;
+11 KILL DD,DO
SET DLAYGO=399.1
SET DIC="^DGCR(399.1,"
SET DIC(0)="L"
SET X=$EXTRACT($PIECE(IBLN,U,8),1,60)
DO FILE^DICN
KILL DIC
IF Y<1
KILL X,Y
QUIT
+12 SET IBFN=+Y
SET IBCNT=IBCNT+1
+13 ;
+14 SET DR=".02////"_$PIECE(IBLN,U,3)_";"_$PIECE(IBLN,U,2)_"////"_1
+15 SET DR=DR_$SELECT($PIECE(IBLN,U,4)'="":";.03////"_$PIECE(IBLN,U,4),1:"")_$SELECT($PIECE(IBLN,U,5)'="":";.16////"_$PIECE(IBLN,U,5),1:"")
+16 SET DR=DR_$SELECT($PIECE(IBLN,U,6)'="":";.17////"_$PIECE(IBLN,U,6),1:"")_$SELECT($PIECE(IBLN,U,7)'="":";.19////"_$PIECE(IBLN,U,7),1:"")
+17 ;
+18 SET DIE="^DGCR(399.1,"
SET DA=+IBFN
DO ^DIE
KILL DIE,DA,DR,X,Y
End DoDot:1
+19 ;
MSG ;add message to install giving count and type of codes added
+1 DO BMES^XPDUTL(" "_IBCNT_" "_IBTYPE_" added to file (#399.1)")
+2 QUIT
+3 ;
MCCRUTL(X,P) ; returns IFN of item in 399.1 if Code is found and piece P is true
+1 ;
+2 NEW IBX,IBY
SET IBY=""
+3 IF $GET(X)'=""
SET IBX=0
FOR
SET IBX=$ORDER(^DGCR(399.1,"C",X,IBX))
if 'IBX
QUIT
IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(P))
SET IBY=IBX
+4 QUIT IBY
+5 ;
+6 ;
MUCF ; TYPE #^TYPE FLD^.02 CODE ^.03 ABBR^.16 OCC REL^.17 OCC SPAN^.19 VC AMNT^.01 NAME
+1 ;;
+2 ;;^UB-92 Value Codes
+3 ;;11^.18^A0^^^^^SPECIAL ZIP CODE REPORTING
+4 ;;
