BGOVCPT2 ; IHS/BAO/TMD - Manage V CPT PART 2 ;25-Feb-2013 15:56;DU
;;1.1;BGO COMPONENTS;**1,3,5,6,8,9,12**;Mar 20, 2007;Build 5
;---------------------------------------------
; Lookup CPT code for input
; INP = Lookup Text [1] ^ Use Lexicon [2] ^ Date [3] ^ Exclude Med [4] ^ Exclude Surg [5] ^
; Exclude HCPCS [6] ^ Exclude E&M [7] ^ Exclude Rad [8] ^ Exclude Lab [9] ^
; Exclude Anesth [10] ^ Exclude Home [11]
; RET = List of CPT4 codes matching selection criteria in format:
; Description ^ CPT IEN ^ CPT Code ^ Narrative
CPTLKUP(RET,INP) ;EP
N LKUP,VDT,HCPCS,CNT,DIC,X,XTLKSAY,BGO,LEX,RES
N HOME,MED,SURG,HCPCS,EM,RAD,LAB,ANEST,DATE
S RET=$$TMPGBL^BGOUTL
S LKUP=$P(INP,U)
S LEX=$P(INP,U,2)
S VDT=$$CVTDATE^BGOUTL($P(INP,U,3))
;IHS/MSC/MGH Patch 9 - make a vdate
I VDT="" S DATE="TODAY",VDT=$$DT^CIAU(DATE)
S MED=$P(INP,U,4) ; Exclude MED
S SURG=$P(INP,U,5) ; Exclude SURG
S HCPCS=$P(INP,U,6) ; Exclude HCPCS
S EM=$P(INP,U,7) ; Exclude EM
S RAD=$P(INP,U,8) ; Exclude RAD
S LAB=$P(INP,U,9) ; Exclude LAB
S ANEST=$P(INP,U,10) ; Exclude ANEST
S HOME=$P(INP,U,11) ; Exclude HOME
S CNT=0
I LEX D
.N HITS,CODE
.D LEXLKUP^BGOUTL(.HITS,LKUP_U_"CHP")
.S BGO=0
.F S BGO=$O(HITS(BGO)) Q:'BGO D
..S X=+HITS(BGO)
..S CODE=$$CPTONE^LEXU(X)
..S:CODE="" CODE=$$CPCONE^LEXU(X)
..Q:CODE=""
..S CODE=$O(^ICPT("B",CODE,0))
..D:CODE CHKHITS(CODE)
;Patch 12, removed this lookup because duplicates are needed
;E I $G(DUZ("AG"))="I" D
;.K ^TMP("XTLKHITS",$J)
;.S DIC="^ICPT(",DIC(0)="TM",XTLKSAY=0,X=LKUP
;.D ^DIC
;.I Y'=-1 D
;..D CHKHITS(Y)
;.E D
;..S BGO=0
;..F S BGO=$O(^TMP("XTLKHITS",$J,BGO)) Q:'BGO D
;...D CHKHITS($G(^TMP("XTLKHITS",$J,BGO)))
;.K ^TMP("XTLKHITS",$J)
E D
.D FIND^DIC(81,,".01;2","M",LKUP,,,,,"RES")
.Q:'$O(RES("DILIST",0))
.M ^TMP("XTLKHITS",$J)=RES("DILIST",2)
.S BGO=0 F S BGO=$O(^TMP("XTLKHITS",$J,BGO)) Q:'BGO D
..D CHKHITS($G(^TMP("XTLKHITS",$J,BGO)))
.K ^TMP("XTLKHITS",$J)
Q
; Add code to output if meets criteria
CHKHITS(CPTIEN) ;
N N0,CODE,DESC,NARR,ISNUM,X,CHK
S CPTIEN=+CPTIEN,N0=$G(^ICPT(CPTIEN,0))
Q:'$L(N0)
;IHS/MSC/MGH Patch 9 for non-CSV sites
I '$$CSVACT^BGOUTL2() D I CHK=1 Q
.S CHK=0
.I $P(N0,U,4)=1 S CHK=1
.I +$P(N0,U,7) S CHK=1
S CODE=$P(N0,U),ISNUM=$TR(CODE,"0123456789")=""
I ISNUM,MED,CODE>89999,CODE<99200 Q
I ISNUM,SURG,CODE>9999,CODE<70000 Q
I ISNUM,HCPCS,$E(CODE)?1A Q
I ISNUM,EM,CODE>99200,CODE<99500 Q
I ISNUM,HOME,CODE>99499,CODE<99605 Q
I ISNUM,RAD,CODE>69999,CODE<80000 Q
I ISNUM,LAB,CODE>79999,CODE<90000 Q
I ISNUM,ANEST,CODE>0,CODE<10000 Q
;I VDT,$P(N0,U,7),$$FMDIFF^XLFDT(VDT,$P(N0,U,7))>-1 Q
;IHS/MSC/MGH added to check if code is effective on date
;IHS/MSC/MGH changed dates patch 9
N XX S XX=DT_"^1"
I VDT D I $P(XX,U,2)'=1 Q
.N CHKDT
.S CHKDT=VDT I VDT<2890101 S CHKDT=2890101
.I $$CSVACT^BGOUTL2() S XX=$$EFF^ICPTSUPT(81,CPTIEN,CHKDT)
S DESC=$P(N0,U,2)
S NARR="",X=0
F S X=$O(^ICPT(CPTIEN,"D",X)) Q:'X S NARR=NARR_$S(NARR="":"",1:" ")_$P($G(^ICPT(CPTIEN,"D",X,0)),U)
S:NARR="" NARR=DESC
S CNT=CNT+1
S @RET@(CNT)=DESC_U_CPTIEN_U_CODE_U_NARR
Q
; Returns procedures for a visit as a single string
PRCSTR(RET,VCPT) ;EP
N X,PRC
S RET="",X=0,VCPT=+VCPT
F S X=$O(^AUPNVCPT("AD",VCPT,X)) Q:'X D
.S PRC=$P($G(^AUPNVCPT(X,0)),U)
.S:PRC RET=RET_$S($L(RET):"; ",1:"")_$P($G(^ICPT(PRC,0)),U)
Q
; Return CPT modifiers
; INP = Reference CPT Code ^ Reference Date ^ CPT IEN
; RET = Name ^ CPT Modifier Code ^ Modifier IEN
GETMODS(RET,INP) ;EP
N NAME,MOD,CODE,CNT,REC,CPT,CDT,CPTIEN
K RET
S CNT=0,CPT=$P(INP,U),CDT=$P(INP,U,2),CPTIEN=$P(INP,U,3)
I $$CSVACT^BGOUTL2("ICPTCOD") D
.S CDT=$$CVTDATE^BGOUTL(CDT)
.S:'CDT CDT=DT
.Q:CPTIEN=""
.;IHS/MSC/MGH account for dates prior to Jan 1,1990
.I CDT<2890101 S CDT=2890101
.D CODM^ICPTCOD(CPTIEN,"MOD",0,CDT)
.S CODE=""
.F S CODE=$O(MOD(CODE)) Q:'$L(CODE) D
..;PATCH 9 check each mod to see if it applicable
..S REC=MOD(CODE)
..S NAME=$P(REC,U)
..S MOD=$P(REC,U,2)
..S X=$$MODP^ICPTMOD(CPTIEN,MOD,"I")
..I X>0 D
...I NAME="" D
....S NAME=MOD
...S CNT=CNT+1,RET(CNT)=NAME_U_CODE_U_MOD
E D
.S MOD=0
.F S MOD=$O(^AUTTCMOD(MOD)) Q:'MOD D
..S REC=$G(^AUTTCMOD(MOD,0))
..S NAME=$P(REC,U,2)
..S CODE=$P(REC,U)
..Q:CODE=""
..I NAME="" D
...S NAME=CODE
..S CNT=CNT+1,RET(CNT)=NAME_U_CODE_U_MOD
Q
; Screen modifiers against CPT code
CHKMOD(MOD,CPT) ;EP
Q:'$$CSVACT^BGOUTL2("ICPTMOD") 1
Q $$MODP^ICPTMOD(CPT,MOD,"I")>0
BGOVCPT2 ; IHS/BAO/TMD - Manage V CPT PART 2 ;25-Feb-2013 15:56;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,5,6,8,9,12**;Mar 20, 2007;Build 5
+2 ;---------------------------------------------
+3 ; Lookup CPT code for input
+4 ; INP = Lookup Text [1] ^ Use Lexicon [2] ^ Date [3] ^ Exclude Med [4] ^ Exclude Surg [5] ^
+5 ; Exclude HCPCS [6] ^ Exclude E&M [7] ^ Exclude Rad [8] ^ Exclude Lab [9] ^
+6 ; Exclude Anesth [10] ^ Exclude Home [11]
+7 ; RET = List of CPT4 codes matching selection criteria in format:
+8 ; Description ^ CPT IEN ^ CPT Code ^ Narrative
CPTLKUP(RET,INP) ;EP
+1 NEW LKUP,VDT,HCPCS,CNT,DIC,X,XTLKSAY,BGO,LEX,RES
+2 NEW HOME,MED,SURG,HCPCS,EM,RAD,LAB,ANEST,DATE
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET LKUP=$PIECE(INP,U)
+5 SET LEX=$PIECE(INP,U,2)
+6 SET VDT=$$CVTDATE^BGOUTL($PIECE(INP,U,3))
+7 ;IHS/MSC/MGH Patch 9 - make a vdate
+8 IF VDT=""
SET DATE="TODAY"
SET VDT=$$DT^CIAU(DATE)
+9 ; Exclude MED
SET MED=$PIECE(INP,U,4)
+10 ; Exclude SURG
SET SURG=$PIECE(INP,U,5)
+11 ; Exclude HCPCS
SET HCPCS=$PIECE(INP,U,6)
+12 ; Exclude EM
SET EM=$PIECE(INP,U,7)
+13 ; Exclude RAD
SET RAD=$PIECE(INP,U,8)
+14 ; Exclude LAB
SET LAB=$PIECE(INP,U,9)
+15 ; Exclude ANEST
SET ANEST=$PIECE(INP,U,10)
+16 ; Exclude HOME
SET HOME=$PIECE(INP,U,11)
+17 SET CNT=0
+18 IF LEX
Begin DoDot:1
+19 NEW HITS,CODE
+20 DO LEXLKUP^BGOUTL(.HITS,LKUP_U_"CHP")
+21 SET BGO=0
+22 FOR
SET BGO=$ORDER(HITS(BGO))
IF 'BGO
QUIT
Begin DoDot:2
+23 SET X=+HITS(BGO)
+24 SET CODE=$$CPTONE^LEXU(X)
+25 IF CODE=""
SET CODE=$$CPCONE^LEXU(X)
+26 IF CODE=""
QUIT
+27 SET CODE=$ORDER(^ICPT("B",CODE,0))
+28 IF CODE
DO CHKHITS(CODE)
End DoDot:2
End DoDot:1
+29 ;Patch 12, removed this lookup because duplicates are needed
+30 ;E I $G(DUZ("AG"))="I" D
+31 ;.K ^TMP("XTLKHITS",$J)
+32 ;.S DIC="^ICPT(",DIC(0)="TM",XTLKSAY=0,X=LKUP
+33 ;.D ^DIC
+34 ;.I Y'=-1 D
+35 ;..D CHKHITS(Y)
+36 ;.E D
+37 ;..S BGO=0
+38 ;..F S BGO=$O(^TMP("XTLKHITS",$J,BGO)) Q:'BGO D
+39 ;...D CHKHITS($G(^TMP("XTLKHITS",$J,BGO)))
+40 ;.K ^TMP("XTLKHITS",$J)
+41 IF '$TEST
Begin DoDot:1
+42 DO FIND^DIC(81,,".01;2","M",LKUP,,,,,"RES")
+43 IF '$ORDER(RES("DILIST",0))
QUIT
+44 MERGE ^TMP("XTLKHITS",$JOB)=RES("DILIST",2)
+45 SET BGO=0
FOR
SET BGO=$ORDER(^TMP("XTLKHITS",$JOB,BGO))
IF 'BGO
QUIT
Begin DoDot:2
+46 DO CHKHITS($GET(^TMP("XTLKHITS",$JOB,BGO)))
End DoDot:2
+47 KILL ^TMP("XTLKHITS",$JOB)
End DoDot:1
+48 QUIT
+49 ; Add code to output if meets criteria
CHKHITS(CPTIEN) ;
+1 NEW N0,CODE,DESC,NARR,ISNUM,X,CHK
+2 SET CPTIEN=+CPTIEN
SET N0=$GET(^ICPT(CPTIEN,0))
+3 IF '$LENGTH(N0)
QUIT
+4 ;IHS/MSC/MGH Patch 9 for non-CSV sites
+5 IF '$$CSVACT^BGOUTL2()
Begin DoDot:1
+6 SET CHK=0
+7 IF $PIECE(N0,U,4)=1
SET CHK=1
+8 IF +$PIECE(N0,U,7)
SET CHK=1
End DoDot:1
IF CHK=1
QUIT
+9 SET CODE=$PIECE(N0,U)
SET ISNUM=$TRANSLATE(CODE,"0123456789")=""
+10 IF ISNUM
IF MED
IF CODE>89999
IF CODE<99200
QUIT
+11 IF ISNUM
IF SURG
IF CODE>9999
IF CODE<70000
QUIT
+12 IF ISNUM
IF HCPCS
IF $EXTRACT(CODE)?1A
QUIT
+13 IF ISNUM
IF EM
IF CODE>99200
IF CODE<99500
QUIT
+14 IF ISNUM
IF HOME
IF CODE>99499
IF CODE<99605
QUIT
+15 IF ISNUM
IF RAD
IF CODE>69999
IF CODE<80000
QUIT
+16 IF ISNUM
IF LAB
IF CODE>79999
IF CODE<90000
QUIT
+17 IF ISNUM
IF ANEST
IF CODE>0
IF CODE<10000
QUIT
+18 ;I VDT,$P(N0,U,7),$$FMDIFF^XLFDT(VDT,$P(N0,U,7))>-1 Q
+19 ;IHS/MSC/MGH added to check if code is effective on date
+20 ;IHS/MSC/MGH changed dates patch 9
+21 NEW XX
SET XX=DT_"^1"
+22 IF VDT
Begin DoDot:1
+23 NEW CHKDT
+24 SET CHKDT=VDT
IF VDT<2890101
SET CHKDT=2890101
+25 IF $$CSVACT^BGOUTL2()
SET XX=$$EFF^ICPTSUPT(81,CPTIEN,CHKDT)
End DoDot:1
IF $PIECE(XX,U,2)'=1
QUIT
+26 SET DESC=$PIECE(N0,U,2)
+27 SET NARR=""
SET X=0
+28 FOR
SET X=$ORDER(^ICPT(CPTIEN,"D",X))
IF 'X
QUIT
SET NARR=NARR_$SELECT(NARR="":"",1:" ")_$PIECE($GET(^ICPT(CPTIEN,"D",X,0)),U)
+29 IF NARR=""
SET NARR=DESC
+30 SET CNT=CNT+1
+31 SET @RET@(CNT)=DESC_U_CPTIEN_U_CODE_U_NARR
+32 QUIT
+33 ; Returns procedures for a visit as a single string
PRCSTR(RET,VCPT) ;EP
+1 NEW X,PRC
+2 SET RET=""
SET X=0
SET VCPT=+VCPT
+3 FOR
SET X=$ORDER(^AUPNVCPT("AD",VCPT,X))
IF 'X
QUIT
Begin DoDot:1
+4 SET PRC=$PIECE($GET(^AUPNVCPT(X,0)),U)
+5 IF PRC
SET RET=RET_$SELECT($LENGTH(RET):"; ",1:"")_$PIECE($GET(^ICPT(PRC,0)),U)
End DoDot:1
+6 QUIT
+7 ; Return CPT modifiers
+8 ; INP = Reference CPT Code ^ Reference Date ^ CPT IEN
+9 ; RET = Name ^ CPT Modifier Code ^ Modifier IEN
GETMODS(RET,INP) ;EP
+1 NEW NAME,MOD,CODE,CNT,REC,CPT,CDT,CPTIEN
+2 KILL RET
+3 SET CNT=0
SET CPT=$PIECE(INP,U)
SET CDT=$PIECE(INP,U,2)
SET CPTIEN=$PIECE(INP,U,3)
+4 IF $$CSVACT^BGOUTL2("ICPTCOD")
Begin DoDot:1
+5 SET CDT=$$CVTDATE^BGOUTL(CDT)
+6 IF 'CDT
SET CDT=DT
+7 IF CPTIEN=""
QUIT
+8 ;IHS/MSC/MGH account for dates prior to Jan 1,1990
+9 IF CDT<2890101
SET CDT=2890101
+10 DO CODM^ICPTCOD(CPTIEN,"MOD",0,CDT)
+11 SET CODE=""
+12 FOR
SET CODE=$ORDER(MOD(CODE))
IF '$LENGTH(CODE)
QUIT
Begin DoDot:2
+13 ;PATCH 9 check each mod to see if it applicable
+14 SET REC=MOD(CODE)
+15 SET NAME=$PIECE(REC,U)
+16 SET MOD=$PIECE(REC,U,2)
+17 SET X=$$MODP^ICPTMOD(CPTIEN,MOD,"I")
+18 IF X>0
Begin DoDot:3
+19 IF NAME=""
Begin DoDot:4
+20 SET NAME=MOD
End DoDot:4
+21 SET CNT=CNT+1
SET RET(CNT)=NAME_U_CODE_U_MOD
End DoDot:3
End DoDot:2
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 SET MOD=0
+24 FOR
SET MOD=$ORDER(^AUTTCMOD(MOD))
IF 'MOD
QUIT
Begin DoDot:2
+25 SET REC=$GET(^AUTTCMOD(MOD,0))
+26 SET NAME=$PIECE(REC,U,2)
+27 SET CODE=$PIECE(REC,U)
+28 IF CODE=""
QUIT
+29 IF NAME=""
Begin DoDot:3
+30 SET NAME=CODE
End DoDot:3
+31 SET CNT=CNT+1
SET RET(CNT)=NAME_U_CODE_U_MOD
End DoDot:2
End DoDot:1
+32 QUIT
+33 ; Screen modifiers against CPT code
CHKMOD(MOD,CPT) ;EP
+1 IF '$$CSVACT^BGOUTL2("ICPTMOD")
QUIT 1
+2 QUIT $$MODP^ICPTMOD(CPT,MOD,"I")>0
