- 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 Jan 18, 2025@03:23:10 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