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 ---[H[J[2J[HIB20P526 1601 printed Dec 13, 2024@02:03:26 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 ;
