IB20P532.m

IB20P532 ;ALB/CXW - UB-04 BILL CLASSIFICATION UPDATE; 07/15/2014 

 ;;2.0;INTEGRATED BILLING;**532**;21-MAR-94;Build 26

 ;;Per VA Directive 6402, this routine should not be modified.

 Q

POST ; 

 ; UB-04 bill classification in mccr utility file 399.1

 N IBX,U S U="^"

 D MSG("     IB*2.0*532 Post-Install starts .....")

 D MCR

 D MSG("     IB*2.0*532 Post-Install is complete.")

 Q

 ;

MCR ; UB-04 bill classification in field (#.23/piece 2)

 ; #4 HUMANIT. EMERG (OPT/ESRD) needs to be replaced

 N IBCOD,IBFN,IBPE,IBI,IBNW,IBX,DA,DD,DO,DIC,DIE,DLAYGO,DR,X,Y

 S IBPE=23 D MSG("")

 D MSG(">>> Adding new UB-04 Bill Classification entries to MCCR Utility file (#399.1)")

 F IBI=1:1 S IBX=$P($T(BILCS+IBI),";;",2) Q:IBX=""  D

 . S IBNW=$P(IBX,U),IBCOD=$P(IBX,U,2)

 . S IBFN=+$$EXCODE(IBCOD,IBPE)

 . ; quit if it's found in the file 

 . I IBFN,($P($G(^DGCR(399.1,IBFN,0)),U)=IBNW) D MSG("    #"_IBCOD_" "_IBNW_" already exists in the file") Q

 . K DD,DO S DLAYGO=399.1,DIC="^DGCR(399.1,",DIC(0)="L",X=IBNW D FILE^DICN

 . I Y<1 D MSG(" >> ERROR when adding the UB-04 Bill Classification for "_IBNW_" to the file, Log a Remedy ticket!") Q 

 . S DIE=DIC,DA=+Y,DR=".02///"_IBCOD_";.23///"_$P(IBX,U,3)_";.24///"_$P(IBX,U,4) D ^DIE

 . D MSG("    #"_IBCOD_" "_IBNW_" added")

 D MSG("")

 Q

 ;

MSG(IBX) ;

 D MES^XPDUTL(IBX) Q

 ;

EXCODE(IBCOD,IBPE) ; Returns IEN if code found in the IBPE piece

 N IBX,IBY S IBY=""

 I $G(IBCOD)'="" S IBX=0 F  S IBX=$O(^DGCR(399.1,"C",IBCOD,IBX)) Q:'IBX  I $P($G(^DGCR(399.1,IBX,0)),U,+$G(IBPE)) S IBY=IBX

 Q IBY

 ;

BILCS ; name^code^bill classification^valid location of care values

 ;;LABORATORY SERVICES PROVIDED TO NON-PATIENTS^4^1^1,3

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P532   1698     printed  Apr 09, 2024@21:33:33                                                                                                                                                                                                    Page 2

IB20P532  ;ALB/CXW - UB-04 BILL CLASSIFICATION UPDATE; 07/15/2014 

 +1       ;;2.0;INTEGRATED BILLING;**532**;21-MAR-94;Build 26

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3        QUIT 

POST      ; 

 +1       ; UB-04 bill classification in mccr utility file 399.1

 +2        NEW IBX,U

           SET U="^"

 +3        DO MSG("     IB*2.0*532 Post-Install starts .....")

 +4        DO MCR

 +5        DO MSG("     IB*2.0*532 Post-Install is complete.")

 +6        QUIT 

 +7       ;

MCR       ; UB-04 bill classification in field (#.23/piece 2)

 +1       ; #4 HUMANIT. EMERG (OPT/ESRD) needs to be replaced

 +2        NEW IBCOD,IBFN,IBPE,IBI,IBNW,IBX,DA,DD,DO,DIC,DIE,DLAYGO,DR,X,Y

 +3        SET IBPE=23

           DO MSG("")

 +4        DO MSG(">>> Adding new UB-04 Bill Classification entries to MCCR Utility file (#399.1)")

 +5        FOR IBI=1:1

               SET IBX=$PIECE($TEXT(BILCS+IBI),";;",2)

               if IBX=""

                   QUIT 

               Begin DoDot:1

 +6                SET IBNW=$PIECE(IBX,U)

                   SET IBCOD=$PIECE(IBX,U,2)

 +7                SET IBFN=+$$EXCODE(IBCOD,IBPE)

 +8       ; quit if it's found in the file 

 +9                IF IBFN

                       IF ($PIECE($GET(^DGCR(399.1,IBFN,0)),U)=IBNW)

                           DO MSG("    #"_IBCOD_" "_IBNW_" already exists in the file")

                           QUIT 

 +10               KILL DD,DO

                   SET DLAYGO=399.1

                   SET DIC="^DGCR(399.1,"

                   SET DIC(0)="L"

                   SET X=IBNW

                   DO FILE^DICN

 +11               IF Y<1

                       DO MSG(" >> ERROR when adding the UB-04 Bill Classification for "_IBNW_" to the file, Log a Remedy ticket!")

                       QUIT 

 +12               SET DIE=DIC

                   SET DA=+Y

                   SET DR=".02///"_IBCOD_";.23///"_$PIECE(IBX,U,3)_";.24///"_$PIECE(IBX,U,4)

                   DO ^DIE

 +13               DO MSG("    #"_IBCOD_" "_IBNW_" added")

               End DoDot:1

 +14       DO MSG("")

 +15       QUIT 

 +16      ;

MSG(IBX)  ;

 +1        DO MES^XPDUTL(IBX)

           QUIT 

 +2       ;

EXCODE(IBCOD,IBPE) ; Returns IEN if code found in the IBPE piece

 +1        NEW IBX,IBY

           SET IBY=""

 +2        IF $GET(IBCOD)'=""

               SET IBX=0

               FOR 

                   SET IBX=$ORDER(^DGCR(399.1,"C",IBCOD,IBX))

                   if 'IBX

                       QUIT 

                   IF $PIECE($GET(^DGCR(399.1,IBX,0)),U,+$GET(IBPE))

                       SET IBY=IBX

 +3        QUIT IBY

 +4       ;

BILCS     ; name^code^bill classification^valid location of care values

 +1       ;;LABORATORY SERVICES PROVIDED TO NON-PATIENTS^4^1^1,3

 +2       ;