Routine: RACPTCSV

RACPTCSV ;HISC/SWM - CPT Code Set Version ;2/23/04  09:03

 ;;5.0;Radiology/Nuclear Medicine;**38,46**;Mar 16, 1998

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACPTCSV   6052     printed  Mar 13, 2025@21:38:57                                                                                                                                                                                                    Page 2

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       ;

RACPTCSV.m