IBEFUNC2 ;ALB/ARH - CPT BILLING EXTRINSIC FUNCTIONS II ;11/27/91
;;2.0;INTEGRATED BILLING;**51,266**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
MODLST(MODS,DESC,IBMOD,IBDATE) ; Function returns string of actual modifiers translated
; from the comma delimited string of modifier iens in MODS
; DESC = 1 if description of modifier should be returned in IBMOD(1)
; Must pass IBMOD by reference for this to work
; IBMOD = the ',' delimited list of modifiers,
; IBMOD(1) = the ',' delimited modifier descriptions, if
; DESC = 1 and IBMOD is passed by reference
; IBDATE = Date of Service (opt) for the versioned text description
;
N Z,Z0,IBP
S IBMOD="",IBMOD(1)=""
F Z=1:1:$L(MODS,",") S IBP=$P(MODS,",",Z) I IBP D
. S Z0=$$MOD^ICPTMOD(IBP,"I",$G(IBDATE)) Q:Z0<0
. I $G(DESC) S IBMOD(1)=IBMOD(1)_$S(IBMOD="":"",1:",")_$P(Z0,U,3)
. S IBMOD=IBMOD_$S(IBMOD="":"",1:",")_$P(Z0,U,2)
Q IBMOD
;
CPTSTAT(CPT,DATE) ;determine the overall status for a CPT for given date, assumes today if no date given
;if DATE is not today, assumes that if active in either 409.71 or 350.4 then also active in 81 for that DATE
;(ICPT is not a date sensitive file, so will only check (81) if want todays status), returns:
; 1 - if DATE=DT and CPT currently only active in ICPT file (81) (not active in 409.71 or 350.4)
; 2A - if CPT is Nationally Active only in SD(409.71) and not BASC for DATE
; 2B - if CPT is Locally Active only in SD(409.71) and not BASC for DATE
; 2C - if CPT is Nationally and Locally Active in SD(409.71) and not BASC for DATE
; 3 - if CPT is Billing Active (BASC) in IBE(350.4) and not active in (409.71) for DATE
; 4A - if CPT is Nationally Active in SD(409.71) and Billing Active in IBE(350.4) for DATE
; 4B - if CPT is Locally Active only in SD(409.71) and Billing Active in IBE(350.4) for DATE
; 4C - if CPT is Nationally and Locally Active in SD(409.71) and Billing Active in IBE(350.4) for DATE
; 0 - otherwise
N X,X1,Y,POST
S:'$D(CPT) CPT=0 S:'$D(DATE) DATE=DT S:'DATE DATE=DT
S Y=0,POST="" G:$$CPT^ICPTCOD(+CPT)<1 CEND
I $E(DATE,1,7)=DT G:'$P($$CPT^ICPTCOD(+CPT),"^",7) CEND S Y=1
S X=CPT,X1=DATE D STATUS^SDAMBAE4 I X'["INACTIVE"&(X'="") D
. S Y=2,POST="A" I X["LOCAL" S POST="B" I X["NATIONAL" S POST="C"
I $$CPTBSTAT^IBEFUNC1(CPT,DATE) S Y=3 I POST'="" S Y=Y+1
CEND Q Y_POST
;
TDG(SSN) ;reformat SSN into terminal digit order
; returns either 0 or ssn in terminal digit order
N X,Y,I S Y="" F I=1:1 S X=$E(SSN,I) Q:X="" I X?1N S Y=Y_X
S Y=$S(Y'?9N:0,1:$E(Y,8,9)_$E(Y,6,7)_$E(Y,4,5)_$E(Y,1,3))
ENDP Q Y
;
FFMT ;
S IBLNGX=$$FORMAT($S('$D(IBGRPX):"",1:IBGRPX),$S('$D(IBCPX):"",1:IBCPX)) Q
;
FORMAT(GRP,CP) ;calculate spacing format for clinic CPT list
;input GRP - the ifn of the GROUP to be calculated or ""
; or CP - the ifn of the entry in 350.71 to return format or ""
;returns - "" if GRP not defined in ^IBE(350.7, or GRP of CP not found
; - margin width & intercolumn width ^ header width (same for both groups and catigories)
; ^ procedure name width
;if # of columns not defined for group, assumes 2
;if display charge not defined for group, assumes negative
;assumes that charge and code widths are not variable
N X,DCHG,CD,IC,PN,H,COL,M,CHK
S:'$D(GRP) GRP="" S:'$D(CP) CP="" I 'GRP&'CP S X="" G ENDFMT
S DCHG=10,CD=7,CHK=7,IC=3,M=132
S:'+GRP GRP=$G(^IBE(350.71,+CP,0)),GRP=$S($P(GRP,"^",4):$P(GRP,"^",4),1:$P($G(^IBE(350.71,+$P(GRP,"^",5),0)),"^",4))
S X=$G(^IBE(350.7,+GRP,0)),COL=$P(X,"^",3) S:COL="" COL=2
I X'="" S DCHG=$S($P(X,"^",2):DCHG,1:0),DCHG=DCHG*COL,CD=CD*COL,CHK=CHK*COL
I X'="" S H=(M-(2*COL*IC)),PN=(H-DCHG-CD-CHK)\COL,H=H\COL
ENDFMT Q $S(X="":X,1:IC_"^"_H_"^"_PN)
;
FPO ;
S X=$$PO(DA,X) Q
;
PO(DA,X) ;check that the print order entered has not already been used for the group/sub-header
;used to ensure unique print orders within groups and sub-headers
; input: DA - the IFN of the entry being added/edited may be a subheader or procedure
; X - the print order to check
;returns: "" - if bad input or print order already defined
; X - input value of X if not previously defined for group/sub-header
I '$D(DA)!('$D(^IBE(350.71,+DA,0)))!('$D(X))!('X) S X="" G ENDPO
N Y S Y=^IBE(350.71,+DA,0)
I $P(Y,"^",3)="S",$D(^IBE(350.71,"AG",+$P(Y,"^",4),X)) S X=""
I $P(Y,"^",3)="P",$D(^IBE(350.71,"AS",+$P(Y,"^",5),X)) S X=""
ENDPO Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEFUNC2 4514 printed Oct 16, 2024@18:22:36 Page 2
IBEFUNC2 ;ALB/ARH - CPT BILLING EXTRINSIC FUNCTIONS II ;11/27/91
+1 ;;2.0;INTEGRATED BILLING;**51,266**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
MODLST(MODS,DESC,IBMOD,IBDATE) ; Function returns string of actual modifiers translated
+1 ; from the comma delimited string of modifier iens in MODS
+2 ; DESC = 1 if description of modifier should be returned in IBMOD(1)
+3 ; Must pass IBMOD by reference for this to work
+4 ; IBMOD = the ',' delimited list of modifiers,
+5 ; IBMOD(1) = the ',' delimited modifier descriptions, if
+6 ; DESC = 1 and IBMOD is passed by reference
+7 ; IBDATE = Date of Service (opt) for the versioned text description
+8 ;
+9 NEW Z,Z0,IBP
+10 SET IBMOD=""
SET IBMOD(1)=""
+11 FOR Z=1:1:$LENGTH(MODS,",")
SET IBP=$PIECE(MODS,",",Z)
IF IBP
Begin DoDot:1
+12 SET Z0=$$MOD^ICPTMOD(IBP,"I",$GET(IBDATE))
if Z0<0
QUIT
+13 IF $GET(DESC)
SET IBMOD(1)=IBMOD(1)_$SELECT(IBMOD="":"",1:",")_$PIECE(Z0,U,3)
+14 SET IBMOD=IBMOD_$SELECT(IBMOD="":"",1:",")_$PIECE(Z0,U,2)
End DoDot:1
+15 QUIT IBMOD
+16 ;
CPTSTAT(CPT,DATE) ;determine the overall status for a CPT for given date, assumes today if no date given
+1 ;if DATE is not today, assumes that if active in either 409.71 or 350.4 then also active in 81 for that DATE
+2 ;(ICPT is not a date sensitive file, so will only check (81) if want todays status), returns:
+3 ; 1 - if DATE=DT and CPT currently only active in ICPT file (81) (not active in 409.71 or 350.4)
+4 ; 2A - if CPT is Nationally Active only in SD(409.71) and not BASC for DATE
+5 ; 2B - if CPT is Locally Active only in SD(409.71) and not BASC for DATE
+6 ; 2C - if CPT is Nationally and Locally Active in SD(409.71) and not BASC for DATE
+7 ; 3 - if CPT is Billing Active (BASC) in IBE(350.4) and not active in (409.71) for DATE
+8 ; 4A - if CPT is Nationally Active in SD(409.71) and Billing Active in IBE(350.4) for DATE
+9 ; 4B - if CPT is Locally Active only in SD(409.71) and Billing Active in IBE(350.4) for DATE
+10 ; 4C - if CPT is Nationally and Locally Active in SD(409.71) and Billing Active in IBE(350.4) for DATE
+11 ; 0 - otherwise
+12 NEW X,X1,Y,POST
+13 if '$DATA(CPT)
SET CPT=0
if '$DATA(DATE)
SET DATE=DT
if 'DATE
SET DATE=DT
+14 SET Y=0
SET POST=""
if $$CPT^ICPTCOD(+CPT)<1
GOTO CEND
+15 IF $EXTRACT(DATE,1,7)=DT
if '$PIECE($$CPT^ICPTCOD(+CPT),"^",7)
GOTO CEND
SET Y=1
+16 SET X=CPT
SET X1=DATE
DO STATUS^SDAMBAE4
IF X'["INACTIVE"&(X'="")
Begin DoDot:1
+17 SET Y=2
SET POST="A"
IF X["LOCAL"
SET POST="B"
IF X["NATIONAL"
SET POST="C"
End DoDot:1
+18 IF $$CPTBSTAT^IBEFUNC1(CPT,DATE)
SET Y=3
IF POST'=""
SET Y=Y+1
CEND QUIT Y_POST
+1 ;
TDG(SSN) ;reformat SSN into terminal digit order
+1 ; returns either 0 or ssn in terminal digit order
+2 NEW X,Y,I
SET Y=""
FOR I=1:1
SET X=$EXTRACT(SSN,I)
if X=""
QUIT
IF X?1N
SET Y=Y_X
+3 SET Y=$SELECT(Y'?9N:0,1:$EXTRACT(Y,8,9)_$EXTRACT(Y,6,7)_$EXTRACT(Y,4,5)_$EXTRACT(Y,1,3))
ENDP QUIT Y
+1 ;
FFMT ;
+1 SET IBLNGX=$$FORMAT($SELECT('$DATA(IBGRPX):"",1:IBGRPX),$SELECT('$DATA(IBCPX):"",1:IBCPX))
QUIT
+2 ;
FORMAT(GRP,CP) ;calculate spacing format for clinic CPT list
+1 ;input GRP - the ifn of the GROUP to be calculated or ""
+2 ; or CP - the ifn of the entry in 350.71 to return format or ""
+3 ;returns - "" if GRP not defined in ^IBE(350.7, or GRP of CP not found
+4 ; - margin width & intercolumn width ^ header width (same for both groups and catigories)
+5 ; ^ procedure name width
+6 ;if # of columns not defined for group, assumes 2
+7 ;if display charge not defined for group, assumes negative
+8 ;assumes that charge and code widths are not variable
+9 NEW X,DCHG,CD,IC,PN,H,COL,M,CHK
+10 if '$DATA(GRP)
SET GRP=""
if '$DATA(CP)
SET CP=""
IF 'GRP&'CP
SET X=""
GOTO ENDFMT
+11 SET DCHG=10
SET CD=7
SET CHK=7
SET IC=3
SET M=132
+12 if '+GRP
SET GRP=$GET(^IBE(350.71,+CP,0))
SET GRP=$SELECT($PIECE(GRP,"^",4):$PIECE(GRP,"^",4),1:$PIECE($GET(^IBE(350.71,+$PIECE(GRP,"^",5),0)),"^",4))
+13 SET X=$GET(^IBE(350.7,+GRP,0))
SET COL=$PIECE(X,"^",3)
if COL=""
SET COL=2
+14 IF X'=""
SET DCHG=$SELECT($PIECE(X,"^",2):DCHG,1:0)
SET DCHG=DCHG*COL
SET CD=CD*COL
SET CHK=CHK*COL
+15 IF X'=""
SET H=(M-(2*COL*IC))
SET PN=(H-DCHG-CD-CHK)\COL
SET H=H\COL
ENDFMT QUIT $SELECT(X="":X,1:IC_"^"_H_"^"_PN)
+1 ;
FPO ;
+1 SET X=$$PO(DA,X)
QUIT
+2 ;
PO(DA,X) ;check that the print order entered has not already been used for the group/sub-header
+1 ;used to ensure unique print orders within groups and sub-headers
+2 ; input: DA - the IFN of the entry being added/edited may be a subheader or procedure
+3 ; X - the print order to check
+4 ;returns: "" - if bad input or print order already defined
+5 ; X - input value of X if not previously defined for group/sub-header
+6 IF '$DATA(DA)!('$DATA(^IBE(350.71,+DA,0)))!('$DATA(X))!('X)
SET X=""
GOTO ENDPO
+7 NEW Y
SET Y=^IBE(350.71,+DA,0)
+8 IF $PIECE(Y,"^",3)="S"
IF $DATA(^IBE(350.71,"AG",+$PIECE(Y,"^",4),X))
SET X=""
+9 IF $PIECE(Y,"^",3)="P"
IF $DATA(^IBE(350.71,"AS",+$PIECE(Y,"^",5),X))
SET X=""
ENDPO QUIT X
