RACPTCSV ;HISC/SWM - CPT Code Set Version ;2/23/04 09:03
;;5.0;Radiology/Nuclear Medicine;**38,46**;Mar 16, 1998
Q
ACTC() ; find out if CPT CODE is active
; called from file 70.03 field 2's DIC("S")
; Y = ien file 71
; DA(2) = RADFN
; DA(1) = RADTI
N RAACTIV,RA710,RACPT,RACPTNAM,RADT0,RAMSG,RADATE,RADATV
N RATXT,RAI,RAX ; RATXT is local array of error text
S RAACTIV=1 ; =1 no error, or CPT CODE is active
S RAI=0 ; counter
S RA710=^RAMIS(71,+Y,0)
S RACPT=$P(RA710,U,9)
I RACPT="",($P(RA710,U,6)="D")!($P(RA710,U,6)="S") D S RAACTIV=0
. S RAI=RAI+1
. S RATXT(RAI)="** A Detailed or Series procedure is missing a CPT CODE.**"
. Q
S RADT0=^RADPT(DA(2),"DT",DA(1),0),RADATE=$P(RADT0,U)
I $P(RA710,U,6)="P" D S RAACTIV=0
. S RAI=RAI+1
. S RATXT(RAI)="** Procedure is a parent type. **"
. Q
I $D(^RAMIS(71,+Y,"I"))#2,^("I")'="",^("I")'>DT D S RAACTIV=0
. S RADATV=$$FMTE^XLFDT($P(^RAMIS(71,+Y,"I"),U),2) ; convert inact.dt
. S RAI=RAI+1
. S RATXT(RAI)="** Procedure is inactive since "_RADATV_". **"
. Q
I $P(RA710,U,12)'=$P(^RADPT(DA(2),"DT",DA(1),0),U,2) D S RAACTIV=0
. S RAI=RAI+1
. S RATXT(RAI)="** Procedure's Imaging Type differs from Exam's Imaging Type. **"
. Q
S RADATV=$$FMTE^XLFDT(RADATE,2) ; convert Exam Date
I RACPT,'$$ACTCODE^RACPTMSC(RACPT,RADATE) D S RAACTIV=0
. S RACPTNAM=$P($$NAMCODE^RACPTMSC(RACPT,RADATE),U)
. S RAI=RAI+1
. S RATXT(RAI)="** Procedure's CPT "_RACPTNAM_" is invalid for Exam Date "_RADATV_". **"
.; if registering exam, and order is parent proc, display help message
. I $D(RAOPT("REG")),$P($G(^RAMIS(71,+$P($G(^RAO(75.1,+$G(RAORDS(1)),0)),U,2),0)),U,6)="P" D
.. S RAI=RAI+1
.. S RATXT(RAI)="** Enter ""^"" to skip this descendent"
.. S RAI=RAI+1
.. S RATXT(RAI)=" or enter a procedure with an active CPT code. **"
.. Q
. Q
I RAACTIV Q RAACTIV ; no errors flagged
I '$D(RATXT) Q RAACTIV ; quit warning if no error text in local array
; X is what user typed, or is proc at // if user pressed return key
I $E(RA710,1,$L(X))'=X Q RAACTIV ; quit warning if X'=prcnam begin chars
I $P(^RAMIS(71,Y,0),U)'=X Q RAACTIV ; quit warning if lookup prcnam '= X
; if registering, quit warning if both met:
; if user input matches order's procedure (frm descnd if parnt ordr)
; if lookup IEN isn't same as order's proc's ien
; note: RAPRC won't exist if procs added aftr descnts entered
I $D(RAOPT("REG")),X=$G(RAPRC),Y'=$G(RAPROCI) Q RAACTIV
S RAMSG=$P(RA710,U)
D EN^DDIOL(RAMSG,,"!")
S RAI=0
F S RAI=$O(RATXT(RAI)) Q:'RAI S RAMSG=RATXT(RAI) D EN^DDIOL(RAMSG,,"!?4")
S RAMSG=""
D EN^DDIOL(RAMSG,,"!") ; put blank line after listing
Q RAACTIV
FUTC() ; called from input templates [RA EXAM EDIT], [RA STATUS CHANGE]
; IF exam date is future to first Log Date:
; check CPT CODE when/after that date arrives
; and last Log Date isn't later than Exam Date
; assumes existing RADFN,RADTI,RACNI,RADTE
; RETURNS 0=inact.CPT Code, 1=active CPT Code
N RADTEX,RARET,RALOG1,RALOGL,RA71,RACPTNAM,RAMSG,RAX
S RARET=1 ; default return to 1 (active)
S RAX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0) G:RAX="" FUTCQ
S RADTEX=RADTE\1 ; date portion of RADTE
S RALOG1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",0)) G:'RALOG1 FUTCQ
S RALOG1=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOG1,0)\1 G:'RALOG1 FUTCQ ;dt portion 1st log date
G:RALOG1'<RADTEX FUTCQ ;1st Log Date same/greater than Exam Date
G:DT<RADTEX FUTCQ ; future Exam Date hasn't arrived yet
S RALOGL=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",""),-1) G:'RALOGL FUTCQ
S RALOGL=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOGL,0)\1 ;dt portion last log date
G:RALOGL'<RADTEX FUTCQ ;latest Log Date = OR > Exam Date
; now check CPT CODE from case record
S RA71=$G(^RAMIS(71,+$P(RAX,U,2),0))
S RARET=$$ACTCODE^RACPTMSC(+$P(RA71,"^",9),RADTE)
I 'RARET D
. S RACPTNAM=$P($$NAMCODE^RACPTMSC(+$P(RA71,"^",9),RADTE),U)
. S RAMSG="*** Exam was registered with a future date, and since ***"
. D EN^DDIOL(RAMSG,,"!?4")
. S RAMSG="*** registration, its CPT Code "_RACPTNAM_" has been inactivated. ***"
. D EN^DDIOL(RAMSG,,"!?4")
. S RAMSG="You must choose a procedure that has an active CPT Code."
. D EN^DDIOL(RAMSG,,"!!?4")
. D EN^DDIOL(" ",,"!?4")
. Q
FUTCQ ;
Q RARET
FUTCMOD() ; called from input templates [RA EXAM EDIT], [RA STATUS CHANGE]
; IF exam date is future to first Log Date:
; check CPT Modifier when/after that date arrives
; and last Log Date isn't later than Exam Date
; assumes existing RADFN,RADTI,RACNI,RADTE
; RETURNS 0=at least one CPT Mod is inactive, 1=all CPT Mods active
N RADTEX,RARET,RALOG1,RALOGL,RA813,RAMSG,RA0,RA1,RAX,RAMODSTR
S RARET=1 ;default return value to 1
G:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0)) FUTCMODQ ; no cpt mod entered
S RADTEX=RADTE\1 ; date portion of RADTE
S RALOG1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",0)) G:'RALOG1 FUTCMODQ
S RALOG1=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOG1,0)\1 G:'RALOG1 FUTCMODQ ;dt portion 1st log date
G:RALOG1'<RADTEX FUTCMODQ ; 1st Log date same/greater than Exam Date
G:DT<RADTEX FUTCMODQ ; future Exam Date hasn't arrived yet
S RALOGL=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",""),-1) G:'RALOGL FUTCMODQ
S RALOGL=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOGL,0)\1 G:'RALOGL FUTCMODQ ;dt portion last log date
G:RALOGL'<RADTEX FUTCMODQ ;latest Log Date = OR > Exam Date
; now check all CPT Mods from case record
S RA1=0 F S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1)) Q:'RA1 D
. S RAX=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1,0)
. S RA0=$$ACTMOD^RACPTMSC(RAX,RADTE)
. I 'RA0 S RARET=0 D
.. S RAMSG="Exam was registered with a future date, and since registration,"
.. D EN^DDIOL(RAMSG,,"!?4")
.. S RAMSG=$P(RAMODSTR,"^",2)_" "_$P(RAMODSTR,"^",3)_" has been inactivated."
.. D EN^DDIOL(RAMSG,,"!?4")
.. Q
. Q
I 'RARET D EN^DDIOL("You must delete the inactive CPT Modifier(s) before you can continue.",,"!?4")
FUTCMODQ ;
Q RARET
;
RACPTCSV ;HISC/SWM - CPT Code Set Version ;2/23/04 09:03
+1 ;;5.0;Radiology/Nuclear Medicine;**38,46**;Mar 16, 1998
+2 QUIT
ACTC() ; find out if CPT CODE is active
+1 ; called from file 70.03 field 2's DIC("S")
+2 ; Y = ien file 71
+3 ; DA(2) = RADFN
+4 ; DA(1) = RADTI
+5 NEW RAACTIV,RA710,RACPT,RACPTNAM,RADT0,RAMSG,RADATE,RADATV
+6 ; RATXT is local array of error text
NEW RATXT,RAI,RAX
+7 ; =1 no error, or CPT CODE is active
SET RAACTIV=1
+8 ; counter
SET RAI=0
+9 SET RA710=^RAMIS(71,+Y,0)
+10 SET RACPT=$PIECE(RA710,U,9)
+11 IF RACPT=""
IF ($PIECE(RA710,U,6)="D")!($PIECE(RA710,U,6)="S")
Begin DoDot:1
+12 SET RAI=RAI+1
+13 SET RATXT(RAI)="** A Detailed or Series procedure is missing a CPT CODE.**"
+14 QUIT
End DoDot:1
SET RAACTIV=0
+15 SET RADT0=^RADPT(DA(2),"DT",DA(1),0)
SET RADATE=$PIECE(RADT0,U)
+16 IF $PIECE(RA710,U,6)="P"
Begin DoDot:1
+17 SET RAI=RAI+1
+18 SET RATXT(RAI)="** Procedure is a parent type. **"
+19 QUIT
End DoDot:1
SET RAACTIV=0
+20 IF $DATA(^RAMIS(71,+Y,"I"))#2
IF ^("I")'=""
IF ^("I")'>DT
Begin DoDot:1
+21 ; convert inact.dt
SET RADATV=$$FMTE^XLFDT($PIECE(^RAMIS(71,+Y,"I"),U),2)
+22 SET RAI=RAI+1
+23 SET RATXT(RAI)="** Procedure is inactive since "_RADATV_". **"
+24 QUIT
End DoDot:1
SET RAACTIV=0
+25 IF $PIECE(RA710,U,12)'=$PIECE(^RADPT(DA(2),"DT",DA(1),0),U,2)
Begin DoDot:1
+26 SET RAI=RAI+1
+27 SET RATXT(RAI)="** Procedure's Imaging Type differs from Exam's Imaging Type. **"
+28 QUIT
End DoDot:1
SET RAACTIV=0
+29 ; convert Exam Date
SET RADATV=$$FMTE^XLFDT(RADATE,2)
+30 IF RACPT
IF '$$ACTCODE^RACPTMSC(RACPT,RADATE)
Begin DoDot:1
+31 SET RACPTNAM=$PIECE($$NAMCODE^RACPTMSC(RACPT,RADATE),U)
+32 SET RAI=RAI+1
+33 SET RATXT(RAI)="** Procedure's CPT "_RACPTNAM_" is invalid for Exam Date "_RADATV_". **"
+34 ; if registering exam, and order is parent proc, display help message
+35 IF $DATA(RAOPT("REG"))
IF $PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAO(75.1,+$GET(RAORDS(1)),0)),U,2),0)),U,6)="P"
Begin DoDot:2
+36 SET RAI=RAI+1
+37 SET RATXT(RAI)="** Enter ""^"" to skip this descendent"
+38 SET RAI=RAI+1
+39 SET RATXT(RAI)=" or enter a procedure with an active CPT code. **"
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
SET RAACTIV=0
+42 ; no errors flagged
IF RAACTIV
QUIT RAACTIV
+43 ; quit warning if no error text in local array
IF '$DATA(RATXT)
QUIT RAACTIV
+44 ; X is what user typed, or is proc at // if user pressed return key
+45 ; quit warning if X'=prcnam begin chars
IF $EXTRACT(RA710,1,$LENGTH(X))'=X
QUIT RAACTIV
+46 ; quit warning if lookup prcnam '= X
IF $PIECE(^RAMIS(71,Y,0),U)'=X
QUIT RAACTIV
+47 ; if registering, quit warning if both met:
+48 ; if user input matches order's procedure (frm descnd if parnt ordr)
+49 ; if lookup IEN isn't same as order's proc's ien
+50 ; note: RAPRC won't exist if procs added aftr descnts entered
+51 IF $DATA(RAOPT("REG"))
IF X=$GET(RAPRC)
IF Y'=$GET(RAPROCI)
QUIT RAACTIV
+52 SET RAMSG=$PIECE(RA710,U)
+53 DO EN^DDIOL(RAMSG,,"!")
+54 SET RAI=0
+55 FOR
SET RAI=$ORDER(RATXT(RAI))
IF 'RAI
QUIT
SET RAMSG=RATXT(RAI)
DO EN^DDIOL(RAMSG,,"!?4")
+56 SET RAMSG=""
+57 ; put blank line after listing
DO EN^DDIOL(RAMSG,,"!")
+58 QUIT RAACTIV
FUTC() ; called from input templates [RA EXAM EDIT], [RA STATUS CHANGE]
+1 ; IF exam date is future to first Log Date:
+2 ; check CPT CODE when/after that date arrives
+3 ; and last Log Date isn't later than Exam Date
+4 ; assumes existing RADFN,RADTI,RACNI,RADTE
+5 ; RETURNS 0=inact.CPT Code, 1=active CPT Code
+6 NEW RADTEX,RARET,RALOG1,RALOGL,RA71,RACPTNAM,RAMSG,RAX
+7 ; default return to 1 (active)
SET RARET=1
+8 SET RAX=^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
IF RAX=""
GOTO FUTCQ
+9 ; date portion of RADTE
SET RADTEX=RADTE\1
+10 SET RALOG1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",0))
IF 'RALOG1
GOTO FUTCQ
+11 ;dt portion 1st log date
SET RALOG1=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOG1,0)\1
IF 'RALOG1
GOTO FUTCQ
+12 ;1st Log Date same/greater than Exam Date
IF RALOG1'<RADTEX
GOTO FUTCQ
+13 ; future Exam Date hasn't arrived yet
IF DT<RADTEX
GOTO FUTCQ
+14 SET RALOGL=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",""),-1)
IF 'RALOGL
GOTO FUTCQ
+15 ;dt portion last log date
SET RALOGL=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOGL,0)\1
+16 ;latest Log Date = OR > Exam Date
IF RALOGL'<RADTEX
GOTO FUTCQ
+17 ; now check CPT CODE from case record
+18 SET RA71=$GET(^RAMIS(71,+$PIECE(RAX,U,2),0))
+19 SET RARET=$$ACTCODE^RACPTMSC(+$PIECE(RA71,"^",9),RADTE)
+20 IF 'RARET
Begin DoDot:1
+21 SET RACPTNAM=$PIECE($$NAMCODE^RACPTMSC(+$PIECE(RA71,"^",9),RADTE),U)
+22 SET RAMSG="*** Exam was registered with a future date, and since ***"
+23 DO EN^DDIOL(RAMSG,,"!?4")
+24 SET RAMSG="*** registration, its CPT Code "_RACPTNAM_" has been inactivated. ***"
+25 DO EN^DDIOL(RAMSG,,"!?4")
+26 SET RAMSG="You must choose a procedure that has an active CPT Code."
+27 DO EN^DDIOL(RAMSG,,"!!?4")
+28 DO EN^DDIOL(" ",,"!?4")
+29 QUIT
End DoDot:1
FUTCQ ;
+1 QUIT RARET
FUTCMOD() ; called from input templates [RA EXAM EDIT], [RA STATUS CHANGE]
+1 ; IF exam date is future to first Log Date:
+2 ; check CPT Modifier when/after that date arrives
+3 ; and last Log Date isn't later than Exam Date
+4 ; assumes existing RADFN,RADTI,RACNI,RADTE
+5 ; RETURNS 0=at least one CPT Mod is inactive, 1=all CPT Mods active
+6 NEW RADTEX,RARET,RALOG1,RALOGL,RA813,RAMSG,RA0,RA1,RAX,RAMODSTR
+7 ;default return value to 1
SET RARET=1
+8 ; no cpt mod entered
IF '$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))
GOTO FUTCMODQ
+9 ; date portion of RADTE
SET RADTEX=RADTE\1
+10 SET RALOG1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",0))
IF 'RALOG1
GOTO FUTCMODQ
+11 ;dt portion 1st log date
SET RALOG1=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOG1,0)\1
IF 'RALOG1
GOTO FUTCMODQ
+12 ; 1st Log date same/greater than Exam Date
IF RALOG1'<RADTEX
GOTO FUTCMODQ
+13 ; future Exam Date hasn't arrived yet
IF DT<RADTEX
GOTO FUTCMODQ
+14 SET RALOGL=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",""),-1)
IF 'RALOGL
GOTO FUTCMODQ
+15 ;dt portion last log date
SET RALOGL=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"L",RALOGL,0)\1
IF 'RALOGL
GOTO FUTCMODQ
+16 ;latest Log Date = OR > Exam Date
IF RALOGL'<RADTEX
GOTO FUTCMODQ
+17 ; now check all CPT Mods from case record
+18 SET RA1=0
FOR
SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1))
IF 'RA1
QUIT
Begin DoDot:1
+19 SET RAX=+^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1,0)
+20 SET RA0=$$ACTMOD^RACPTMSC(RAX,RADTE)
+21 IF 'RA0
SET RARET=0
Begin DoDot:2
+22 SET RAMSG="Exam was registered with a future date, and since registration,"
+23 DO EN^DDIOL(RAMSG,,"!?4")
+24 SET RAMSG=$PIECE(RAMODSTR,"^",2)_" "_$PIECE(RAMODSTR,"^",3)_" has been inactivated."
+25 DO EN^DDIOL(RAMSG,,"!?4")
+26 QUIT
End DoDot:2
+27 QUIT
End DoDot:1
+28 IF 'RARET
DO EN^DDIOL("You must delete the inactive CPT Modifier(s) before you can continue.",,"!?4")
FUTCMODQ ;
+1 QUIT RARET
+2 ;
