IB20P526.m

IB20P526 ;ALB/CXW - UPDATE MCCR UTILITY ; 07/01/2014

 ;;2.0;INTEGRATED BILLING;**526**;21-MAR-94;Build 17

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

 Q

POST ; 

 ; Update mccr utility file 399.1

 N U S U="^"

 D MES^XPDUTL("Patch Post-Install starts")

 D MCR

 D MES^XPDUTL("Patch Post-Install is complete.")

 Q

 ;

MCR ; 1 type of code

 N IBCNT,IBCOD,IBPE,IBFD,IBFN,IBI,IBX,DA,DIE,DR,X,Y

 ;

 ; Occurrence code flag in field #.11/piece 4

 ; Occurrence span flag in field #.17/piece 10

 S IBCNT=0,IBPE=10,IBFD=.17

 D MES^XPDUTL(""),MES^XPDUTL(">>>Occurrence Span Code")

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

 . ; store in mccr utility file

 . S IBFN=+$$EXCODE($P(IBX,U),IBPE)

 . I 'IBFN D MES^XPDUTL("   #"_$P(IBX,U)_" "_$P(IBX,U,2)_" not defined") Q 

 . ; no update if new name exists

 . I $P($G(^DGCR(399.1,IBFN,0)),U,1)=$P(IBX,U,3) D MES^XPDUTL("   #"_$P(IBX,U)_" "_$P(IBX,U,3)_" already updated") Q 

 . S DIE="^DGCR(399.1,",DA=IBFN,DR=".01///"_$P(IBX,U,3) D ^DIE

 . S IBCNT=IBCNT+1 D MES^XPDUTL("   #"_$P(IBX,U)_" "_$P(IBX,U,3)_" updated")

 ;

 D MES^XPDUTL("Total "_IBCNT_" code"_$S(IBCNT'=1:"s",1:"")_" updated in the MCCR Utility file (#399.1)")

 D MES^XPDUTL("")

 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

 ;

OCCPU ; Occurrence span code^old name^new name

 ;;72^FIRST/LAST VISIT^ID OF OPT TIME ASSOC WITH AN IP HOSP ADMIT & IP CLM FOR PYMT

 ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IB20P526   1601     printed  Apr 09, 2024@21:19:13                                                                                                                                                                                                    Page 2

IB20P526  ;ALB/CXW - UPDATE MCCR UTILITY ; 07/01/2014

 +1       ;;2.0;INTEGRATED BILLING;**526**;21-MAR-94;Build 17

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

 +3        QUIT 

POST      ; 

 +1       ; Update mccr utility file 399.1

 +2        NEW U

           SET U="^"

 +3        DO MES^XPDUTL("Patch Post-Install starts")

 +4        DO MCR

 +5        DO MES^XPDUTL("Patch Post-Install is complete.")

 +6        QUIT 

 +7       ;

MCR       ; 1 type of code

 +1        NEW IBCNT,IBCOD,IBPE,IBFD,IBFN,IBI,IBX,DA,DIE,DR,X,Y

 +2       ;

 +3       ; Occurrence code flag in field #.11/piece 4

 +4       ; Occurrence span flag in field #.17/piece 10

 +5        SET IBCNT=0

           SET IBPE=10

           SET IBFD=.17

 +6        DO MES^XPDUTL("")

           DO MES^XPDUTL(">>>Occurrence Span Code")

 +7        FOR IBI=1:1

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

               if IBX=""

                   QUIT 

               Begin DoDot:1

 +8       ; store in mccr utility file

 +9                SET IBFN=+$$EXCODE($PIECE(IBX,U),IBPE)

 +10               IF 'IBFN

                       DO MES^XPDUTL("   #"_$PIECE(IBX,U)_" "_$PIECE(IBX,U,2)_" not defined")

                       QUIT 

 +11      ; no update if new name exists

 +12               IF $PIECE($GET(^DGCR(399.1,IBFN,0)),U,1)=$PIECE(IBX,U,3)

                       DO MES^XPDUTL("   #"_$PIECE(IBX,U)_" "_$PIECE(IBX,U,3)_" already updated")

                       QUIT 

 +13               SET DIE="^DGCR(399.1,"

                   SET DA=IBFN

                   SET DR=".01///"_$PIECE(IBX,U,3)

                   DO ^DIE

 +14               SET IBCNT=IBCNT+1

                   DO MES^XPDUTL("   #"_$PIECE(IBX,U)_" "_$PIECE(IBX,U,3)_" updated")

               End DoDot:1

 +15      ;

 +16       DO MES^XPDUTL("Total "_IBCNT_" code"_$SELECT(IBCNT'=1:"s",1:"")_" updated in the MCCR Utility file (#399.1)")

 +17       DO MES^XPDUTL("")

 +18       QUIT 

 +19      ;

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       ;

OCCPU     ; Occurrence span code^old name^new name

 +1       ;;72^FIRST/LAST VISIT^ID OF OPT TIME ASSOC WITH AN IP HOSP ADMIT & IP CLM FOR PYMT

 +2       ;