- 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 23, 2025@18:16:42 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 ;;
