Routine: IB20P553

IB20P553 ;ALB/CXW - UPDATE OCCURRENCE SPAN CODES ;07/01/2015

 ;;2.0;INTEGRATED BILLING;**553**;21-MAR-94;Build 22

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

POST ;

 ; Update occurrence span codes in mccr utility file 399.1

 N IBZ,U S U="^"

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

 D MCR

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

MCR ; Occurrence span codes update

 N IBA,IBB,IBCNT,IBFN,IBPE4,IBPE10,IBI,IBX,DA,DR,DIE,X,Y

 ; Occurrence span code flags in fields #.11/piece 4, #.17/piece 10

 S IBPE4=4,IBPE10=10,IBCNT=0

 D MSG(""),MSG(" >>>Occurrence Span Code")

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

 . S IBA=$P(IBX,U),IBB=$P(IBX,U,2)

 . S IBFN=+$$EXCODE(IBA,IBPE4,IBPE10)

 . I 'IBFN D MSG("   #"_IBA_" not found, no update") Q

 . I $P(^DGCR(399.1,IBFN,0),U)=IBB D MSG("   #"_IBA_" "_IBB_" already exists, no update") Q

 . S DIE="^DGCR(399.1,",DA=IBFN,DR=".01///"_IBB D ^DIE

 . S IBCNT=IBCNT+1

 . D MSG("   #"_IBA_" "_IBB_" updated")

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

 D MSG("")

EXCODE(IBA,IBPE4,IBPE10) ; Returns IEN if code found in IBPE4/IBPE10 pieces

 N IBX,IBY,IBOSC S IBY=""

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

 Q IBY

MSG(IBZ) ;

 D MES^XPDUTL(IBZ) Q

OCCPU ; Occurrence span code^name^update (11)

 ;;70^QUALIFYING STAY DATES FOR SNF USE ONLY^1

 ;;71^PRIOR STAY DATES^1

 ;;72^ID OF OPT TIME ASSOC WITH AN IP HOSP ADMIT & IP CLM FOR PYMT^1

 ;;73^BENEFITS ELIGIBILITY PERIOD^1

 ;;74^NONCOVERED LEVEL OF CARE^1

 ;;75^SNF LEVEL OF CARE^1

 ;;76^PATIENT LIABILITY^1

 ;;77^PROVIDER LIABILITY PERIOD^1

 ;;78^SNF PRIOR STAY DATES^1

 ;;79^PAYER CODE^1

 ;;80^PRIOR SAME-SNF STAY DATES FOR PAYMENT BAN PURPOSES^1

;;Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P553   1931     printed  Mar 13, 2025@21:08:25                                                                                                                                                                                                    Page 2

IB20P553  ;ALB/CXW - UPDATE OCCURRENCE SPAN CODES ;07/01/2015

 +1       ;;2.0;INTEGRATED BILLING;**553**;21-MAR-94;Build 22

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

 +3        QUIT

POST      ;

 +1       ; Update occurrence span codes in mccr utility file 399.1

 +2        NEW IBZ,U

           SET U="^"

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

 +4        DO MCR

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

 +6        QUIT

 +7       ;

MCR       ; Occurrence span codes update

 +1        NEW IBA,IBB,IBCNT,IBFN,IBPE4,IBPE10,IBI,IBX,DA,DR,DIE,X,Y

 +2       ; Occurrence span code flags in fields #.11/piece 4, #.17/piece 10

 +3        SET IBPE4=4

           SET IBPE10=10

           SET IBCNT=0

 +4        DO MSG("")

           DO MSG(" >>>Occurrence Span Code")

 +5        FOR IBI=1:1

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

               if IBX="Q"

                   QUIT

               Begin DoDot:1

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

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

 +7                SET IBFN=+$$EXCODE(IBA,IBPE4,IBPE10)

 +8                IF 'IBFN

                       DO MSG("   #"_IBA_" not found, no update")

                       QUIT

 +9                IF $PIECE(^DGCR(399.1,IBFN,0),U)=IBB

                       DO MSG("   #"_IBA_" "_IBB_" already exists, no update")

                       QUIT

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

                   SET DA=IBFN

                   SET DR=".01///"_IBB

                   DO ^DIE

 +11               SET IBCNT=IBCNT+1

 +12               DO MSG("   #"_IBA_" "_IBB_" updated")

               End DoDot:1

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

 +14       DO MSG("")

 +15       QUIT

 +16      ;

EXCODE(IBA,IBPE4,IBPE10) ; Returns IEN if code found in IBPE4/IBPE10 pieces

 +1        NEW IBX,IBY,IBOSC

           SET IBY=""

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

               SET IBX=0

FOR

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

                   if 'IBX

                       QUIT

                   SET IBOSC=$GET(^DGCR(399.1,IBX,0))

                   IF $PIECE(IBOSC,U,+$GET(IBPE4))

                       IF $PIECE(IBOSC,U,+$GET(IBPE10))

                           SET IBY=IBX

 +3        QUIT IBY

 +4       ;

MSG(IBZ)  ;

 +1        DO MES^XPDUTL(IBZ)

           QUIT

 +2       ;

OCCPU     ; Occurrence span code^name^update (11)

 +1       ;;70^QUALIFYING STAY DATES FOR SNF USE ONLY^1

 +2       ;;71^PRIOR STAY DATES^1

 +3       ;;72^ID OF OPT TIME ASSOC WITH AN IP HOSP ADMIT & IP CLM FOR PYMT^1

 +4       ;;73^BENEFITS ELIGIBILITY PERIOD^1

 +5       ;;74^NONCOVERED LEVEL OF CARE^1

 +6       ;;75^SNF LEVEL OF CARE^1

 +7       ;;76^PATIENT LIABILITY^1

 +8       ;;77^PROVIDER LIABILITY PERIOD^1

 +9       ;;78^SNF PRIOR STAY DATES^1

 +10      ;;79^PAYER CODE^1

 +11      ;;80^PRIOR SAME-SNF STAY DATES FOR PAYMENT BAN PURPOSES^1

 +12      ;;Q

 +13      ;

IB20P553.m