RACPTMSC ;HISC/SWM - CPT Mod screen, misc. ;5/30/00 11:02
;;5.0;Radiology/Nuclear Medicine;**10,19,38**;Mar 16, 1998
Q
SCRN(Y) ;screen entry of cpt mod
; called from file 70.03's field 135's screen
; Y = ien of file 81.3
; RACPT= CPT ien of this exam's procedure
; RADT = exam date
; RAX = screen's outcome, 0=failed
N RACPT,RADT,RAX,RA7002,RA7003,RA1,RA2,RA3
S (RA7002,RA7003)=""
D SET
I RA7002="" Q 0
I RA7003="" Q 0
S RADT=$P(RA7002,U) I 'RADT Q 0
S RACPT=+$P(^RAMIS(71,+$P(RA7003,U,2),0),U,9) I 'RACPT Q 0
S RAX=$$MODP^ICPTMOD(RACPT,+Y,"I",RADT) S:RAX<0 RAX=0
Q RAX
SET ; use Rad vars if available
I $D(RADFN),$D(RADTI),$D(RACNI) S RA1=RADFN,RA2=RADTI,RA3=RACNI G SET23
S RA1=$G(D0),RA2=$G(D1),RA3=$G(D2)
Q:((RA1="")!(RA2="")!(RA3=""))
SET23 S RA7002=$G(^RADPT(RA1,"DT",RA2,0)),RA7003=$G(^RADPT(RA1,"DT",RA2,"P",RA3,0))
Q
DW ; del exam's cpt mods and warn of proc mods
; called from file 70.03's field 2's Mumps xref for kill
; Y = ien of file 81.3
N RA7002,RA7003,RA1,RA2,RA3,RAX,RAROOT
S (RA7002,RA7003)=""
D SET
Q:RA7002=""
Q:RA7003=""
G:'$O(^RADPT(RA1,"DT",RA2,"P",RA3,"CMOD",0)) WARN
S RAX=0 ;del all cpt modifiers
F S RAX=$O(^RADPT(RA1,"DT",RA2,"P",RA3,"CMOD",RAX)) Q:'RAX D
. S RAROOT(70.3135,RAX_","_RA3_","_RA2_","_RA1_",",.01)="@"
. D FILE^DIE("K","RAROOT")
W !!?5,"All previous CPT Modifier(s) are deleted.",!
WARN Q:'$O(^RADPT(RA1,"DT",RA2,"P",RA3,"M","B",0))
S RAX=0 ;warn of existing proc mods
W !!?5,"Current Procedure Modifier(s) :"
F S RAX=$O(^RADPT(RA1,"DT",RA2,"P",RA3,"M",RAX)) Q:'RAX W !?10,$P($G(^RAMIS(71.2,+^(RAX,0),0)),U)
Q
ACTCODE(RA1,RA2) ;outputs CPT code active status
; output=1 active, =0 inactive
; RA1 = CPT CODE, internal or external
; RA2 = date to check CPT Code
N RA
S RA=$$CPT^ICPTCOD(RA1,RA2)
I $P(RA,"^",7)=1 Q 1
Q 0
NAMCODE(RA1,RA2) ;outputs flds #.01 and #2 of CPT record
; RA1 = CPT CODE, internal or external
; RA2 = date to check CPT Code
N RA
S RA=$$CPT^ICPTCOD(RA1,RA2)
S:+RA=-1 RA=""
S RA=$P(RA,"^",2,3)
Q RA
BASICMOD(RA1,RA2) ; outputs basic modifier info
; RA1 = CPT MODIFIER, internal is used here
; RA2 = date to check CPT Modifier
Q $$MOD^ICPTMOD(RA1,"I",RA2)
ACTMOD(RA1,RA2) ; outputs active status of CPT modifier
; RA1 = CPT MODIFIER, internal is used here
; RA2 = date to check CPT Modifier
; output:
; RA3 = 0 is inactive, >0 is active
; RAMODSTR returned from call to MOD^ICPTMOD
N RA3
S RAMODSTR=$$MOD^ICPTMOD(RA1,"I",RA2)
S RA3=+RAMODSTR
S:RA3<0 RA3=0
S:'$P(RAMODSTR,U,7) RA3=0
Q RA3
SETDEFS ; set default CPT Modifiers, called by [RA REGISTER]
; 1st choice, defaults from file 71
; 2nd choice, defaults from file 79.1
N RAROOT
S RAROOT=$S($O(^RAMIS(71,+RAPRI,"DCM",0)):"^RAMIS(71,"_+RAPRI_",""DCM"",",$O(^RA(79.1,+RAMLC,"DCM",0)):"^RA(79.1,"_+RAMLC_",""DCM"",",1:"")
Q:RAROOT=""
N RA1,RA2,RA3,RAFDA,RAIEN,RAMSG
Q:$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0)) ;<--- ???
S RA1=0,RA2=RACNI_","_RADTI_","_RADFN
LOOP1 K RAFDA,RAIEN,RAMSG ;clear arrays each time
S RA1=$O(@(RAROOT_RA1_")")) Q:'RA1
S RA3=+@(RAROOT_RA1_",0)")
; convert ien to external so Updater will validate data
; use DT because we're just getting the external value
S RA3=$$BASICMOD(RA3,DT)
G:+RA3<0 LOOP1 ; skip invalid CPT Modifier
G:'$P(RA3,U,7) LOOP1 ; skip inactive CPT Modifier
S RAFDA(70.3135,"+2,"_RA2_",",.01)=$P(RA3,U,2)
D UPDATE^DIE("E","RAFDA","RAIEN","RAMSG")
G:'$D(RAMSG) LOOP1
W !!,$C(7),"** Unable to enter default CPT Modifier ",$P(RA3,U,2)," (",$P($P(RA3,U,3)," "),") **",!
G LOOP1
DISCMOD ; display existing CPT Modifiers
Q:'$D(RADFN) Q:'$D(RADTI) Q:'$D(RACNI)
N RA1,RA2,RA3 S RA1=0
W:$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1)) !
LOOP2 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1)) Q:'RA1 S RA2=+^(RA1,0)
S RA3=$$BASICMOD(RA2,DT)
S:+RA3<0 RA3=""
; need parse with " " to rid trailing blanks
W !?6,$P(RA3,"^",2),?9,"(",$P($P(RA3,"^",3)," "),") (",$S($P(RA3,"^",7)=1:"",1:"in"),"active)"
G LOOP2
SDP(Y) ; SCREEN DEFAULT cpt mod for a PROCEDURE
; called from file 71's field 135's screen
; Y = ien of file 81.3
; RACPT= CPT ien of this procedure
; RAX = screen's outcome, 0=failed
N RACPT,RAX,RA1,RA2,RA3
S RACPT=+$P(^RAMIS(71,+$G(D0),0),U,9) I 'RACPT Q 0
S RAX=$$MODP^ICPTMOD(RACPT,+Y,"I",DT) S:RAX<0 RAX=0
Q RAX
SDL(Y) ; SCREEN DEFAULT cpt mod for a LOCATION
; called from file 79.1's field 135's screen
; Y = ien of file 81.3
; RAX = screen's outcome; 0=failed
N RAX,RAMODSTR
S RAX=$$ACTMOD(Y,DT) S:RAX<0 RAX=0
Q RAX
DISDCM ;display existing Default CPT Modifers for procedure or location
; file 71 used if called from [RA PROCEDURE EDIT]
; file 79.1 used if called from [RA LOCATION PARAMETERS]
Q:'($D(DA)#2) Q:'$D(DIE)
N RA1,RA2,RA3 S RA1=0
D:DIE["79.1" WARNLOC
I $O(@(DIE_DA_",""DCM"","_RA1_")")) W !
F S RA1=$O(@(DIE_DA_",""DCM"","_RA1_")")) Q:'RA1 S RA2=+^(RA1,0) S RA3=$$BASICMOD(RA2,DT) S:+RA3<0 RA3="" W !?6,$P(RA3,"^",2),?9,"(",$P($P(RA3,"^",3)," "),")"
Q
EHDP ; EXECUTABLE HELP for DEFAULT CPT MODIFIERS (PROC)
N RATXT
S RATXT(1)=" Choose a CPT Modifier that should be automatically stuffed"
S RATXT(2)=" into the exam record with this procedure, during exam"
S RATXT(3)=" registration."
S RATXT(4)=" "
D EN^DDIOL(.RATXT)
Q
EHDL ; EXECUTABLE HELP for DEFAULT CPT MODIFIERS (LOC)
D WARNLOC
N RATXT
S RATXT(1)=" Choose a CPT Modifier that should be automatically stuffed"
S RATXT(2)=" into the exam record, when the following 2 conditions"
S RATXT(3)=" are both met :"
S RATXT(4)=" 1-There is no default CPT Modifier for this exam's procedure."
S RATXT(5)=" 2-This location is the current sign-on (or switched-to) location"
S RATXT(6)=" at the time of registration."
S RATXT(7)=" If your entry is invalid, then during exam registration, this"
S RATXT(8)=" Default CPT Modifier will NOT be stuffed, instead, an error message"
S RATXT(9)=" with the name of the rejected CPT Modifier would be displayed."
S RATXT(10)=" "
D EN^DDIOL(.RATXT)
Q
WARNLOC N RATXT
S RATXT(1)=" +----------------------------------------------------------------+"
S RATXT(2)=" | Your entry cannot be compared with a CPT CODE, so be very sure |"
S RATXT(3)=" | that this is the Default CPT Modifier that you want to stuff |"
S RATXT(4)=" | into every registered exam from this imaging location. |"
S RATXT(5)=" +----------------------------------------------------------------+"
D EN^DDIOL(.RATXT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRACPTMSC 6679 printed Sep 23, 2025@20:10:14 Page 2
RACPTMSC ;HISC/SWM - CPT Mod screen, misc. ;5/30/00 11:02
+1 ;;5.0;Radiology/Nuclear Medicine;**10,19,38**;Mar 16, 1998
+2 QUIT
SCRN(Y) ;screen entry of cpt mod
+1 ; called from file 70.03's field 135's screen
+2 ; Y = ien of file 81.3
+3 ; RACPT= CPT ien of this exam's procedure
+4 ; RADT = exam date
+5 ; RAX = screen's outcome, 0=failed
+6 NEW RACPT,RADT,RAX,RA7002,RA7003,RA1,RA2,RA3
+7 SET (RA7002,RA7003)=""
+8 DO SET
+9 IF RA7002=""
QUIT 0
+10 IF RA7003=""
QUIT 0
+11 SET RADT=$PIECE(RA7002,U)
IF 'RADT
QUIT 0
+12 SET RACPT=+$PIECE(^RAMIS(71,+$PIECE(RA7003,U,2),0),U,9)
IF 'RACPT
QUIT 0
+13 SET RAX=$$MODP^ICPTMOD(RACPT,+Y,"I",RADT)
if RAX<0
SET RAX=0
+14 QUIT RAX
SET ; use Rad vars if available
+1 IF $DATA(RADFN)
IF $DATA(RADTI)
IF $DATA(RACNI)
SET RA1=RADFN
SET RA2=RADTI
SET RA3=RACNI
GOTO SET23
+2 SET RA1=$GET(D0)
SET RA2=$GET(D1)
SET RA3=$GET(D2)
+3 if ((RA1="")!(RA2="")!(RA3=""))
QUIT
SET23 SET RA7002=$GET(^RADPT(RA1,"DT",RA2,0))
SET RA7003=$GET(^RADPT(RA1,"DT",RA2,"P",RA3,0))
+1 QUIT
DW ; del exam's cpt mods and warn of proc mods
+1 ; called from file 70.03's field 2's Mumps xref for kill
+2 ; Y = ien of file 81.3
+3 NEW RA7002,RA7003,RA1,RA2,RA3,RAX,RAROOT
+4 SET (RA7002,RA7003)=""
+5 DO SET
+6 if RA7002=""
QUIT
+7 if RA7003=""
QUIT
+8 if '$ORDER(^RADPT(RA1,"DT",RA2,"P",RA3,"CMOD",0))
GOTO WARN
+9 ;del all cpt modifiers
SET RAX=0
+10 FOR
SET RAX=$ORDER(^RADPT(RA1,"DT",RA2,"P",RA3,"CMOD",RAX))
if 'RAX
QUIT
Begin DoDot:1
+11 SET RAROOT(70.3135,RAX_","_RA3_","_RA2_","_RA1_",",.01)="@"
+12 DO FILE^DIE("K","RAROOT")
End DoDot:1
+13 WRITE !!?5,"All previous CPT Modifier(s) are deleted.",!
WARN if '$ORDER(^RADPT(RA1,"DT",RA2,"P",RA3,"M","B",0))
QUIT
+1 ;warn of existing proc mods
SET RAX=0
+2 WRITE !!?5,"Current Procedure Modifier(s) :"
+3 FOR
SET RAX=$ORDER(^RADPT(RA1,"DT",RA2,"P",RA3,"M",RAX))
if 'RAX
QUIT
WRITE !?10,$PIECE($GET(^RAMIS(71.2,+^(RAX,0),0)),U)
+4 QUIT
ACTCODE(RA1,RA2) ;outputs CPT code active status
+1 ; output=1 active, =0 inactive
+2 ; RA1 = CPT CODE, internal or external
+3 ; RA2 = date to check CPT Code
+4 NEW RA
+5 SET RA=$$CPT^ICPTCOD(RA1,RA2)
+6 IF $PIECE(RA,"^",7)=1
QUIT 1
+7 QUIT 0
NAMCODE(RA1,RA2) ;outputs flds #.01 and #2 of CPT record
+1 ; RA1 = CPT CODE, internal or external
+2 ; RA2 = date to check CPT Code
+3 NEW RA
+4 SET RA=$$CPT^ICPTCOD(RA1,RA2)
+5 if +RA=-1
SET RA=""
+6 SET RA=$PIECE(RA,"^",2,3)
+7 QUIT RA
BASICMOD(RA1,RA2) ; outputs basic modifier info
+1 ; RA1 = CPT MODIFIER, internal is used here
+2 ; RA2 = date to check CPT Modifier
+3 QUIT $$MOD^ICPTMOD(RA1,"I",RA2)
ACTMOD(RA1,RA2) ; outputs active status of CPT modifier
+1 ; RA1 = CPT MODIFIER, internal is used here
+2 ; RA2 = date to check CPT Modifier
+3 ; output:
+4 ; RA3 = 0 is inactive, >0 is active
+5 ; RAMODSTR returned from call to MOD^ICPTMOD
+6 NEW RA3
+7 SET RAMODSTR=$$MOD^ICPTMOD(RA1,"I",RA2)
+8 SET RA3=+RAMODSTR
+9 if RA3<0
SET RA3=0
+10 if '$PIECE(RAMODSTR,U,7)
SET RA3=0
+11 QUIT RA3
SETDEFS ; set default CPT Modifiers, called by [RA REGISTER]
+1 ; 1st choice, defaults from file 71
+2 ; 2nd choice, defaults from file 79.1
+3 NEW RAROOT
+4 SET RAROOT=$SELECT($ORDER(^RAMIS(71,+RAPRI,"DCM",0)):"^RAMIS(71,"_+RAPRI_",""DCM"",",$ORDER(^RA(79.1,+RAMLC,"DCM",0)):"^RA(79.1,"_+RAMLC_",""DCM"",",1:"")
+5 if RAROOT=""
QUIT
+6 NEW RA1,RA2,RA3,RAFDA,RAIEN,RAMSG
+7 ;<--- ???
if $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",0))
QUIT
+8 SET RA1=0
SET RA2=RACNI_","_RADTI_","_RADFN
LOOP1 ;clear arrays each time
KILL RAFDA,RAIEN,RAMSG
+1 SET RA1=$ORDER(@(RAROOT_RA1_")"))
if 'RA1
QUIT
+2 SET RA3=+@(RAROOT_RA1_",0)")
+3 ; convert ien to external so Updater will validate data
+4 ; use DT because we're just getting the external value
+5 SET RA3=$$BASICMOD(RA3,DT)
+6 ; skip invalid CPT Modifier
if +RA3<0
GOTO LOOP1
+7 ; skip inactive CPT Modifier
if '$PIECE(RA3,U,7)
GOTO LOOP1
+8 SET RAFDA(70.3135,"+2,"_RA2_",",.01)=$PIECE(RA3,U,2)
+9 DO UPDATE^DIE("E","RAFDA","RAIEN","RAMSG")
+10 if '$DATA(RAMSG)
GOTO LOOP1
+11 WRITE !!,$CHAR(7),"** Unable to enter default CPT Modifier ",$PIECE(RA3,U,2)," (",$PIECE($PIECE(RA3,U,3)," "),") **",!
+12 GOTO LOOP1
DISCMOD ; display existing CPT Modifiers
+1 if '$DATA(RADFN)
QUIT
if '$DATA(RADTI)
QUIT
if '$DATA(RACNI)
QUIT
+2 NEW RA1,RA2,RA3
SET RA1=0
+3 if $ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1))
WRITE !
LOOP2 SET RA1=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CMOD",RA1))
if 'RA1
QUIT
SET RA2=+^(RA1,0)
+1 SET RA3=$$BASICMOD(RA2,DT)
+2 if +RA3<0
SET RA3=""
+3 ; need parse with " " to rid trailing blanks
+4 WRITE !?6,$PIECE(RA3,"^",2),?9,"(",$PIECE($PIECE(RA3,"^",3)," "),") (",$SELECT($PIECE(RA3,"^",7)=1:"",1:"in"),"active)"
+5 GOTO LOOP2
SDP(Y) ; SCREEN DEFAULT cpt mod for a PROCEDURE
+1 ; called from file 71's field 135's screen
+2 ; Y = ien of file 81.3
+3 ; RACPT= CPT ien of this procedure
+4 ; RAX = screen's outcome, 0=failed
+5 NEW RACPT,RAX,RA1,RA2,RA3
+6 SET RACPT=+$PIECE(^RAMIS(71,+$GET(D0),0),U,9)
IF 'RACPT
QUIT 0
+7 SET RAX=$$MODP^ICPTMOD(RACPT,+Y,"I",DT)
if RAX<0
SET RAX=0
+8 QUIT RAX
SDL(Y) ; SCREEN DEFAULT cpt mod for a LOCATION
+1 ; called from file 79.1's field 135's screen
+2 ; Y = ien of file 81.3
+3 ; RAX = screen's outcome; 0=failed
+4 NEW RAX,RAMODSTR
+5 SET RAX=$$ACTMOD(Y,DT)
if RAX<0
SET RAX=0
+6 QUIT RAX
DISDCM ;display existing Default CPT Modifers for procedure or location
+1 ; file 71 used if called from [RA PROCEDURE EDIT]
+2 ; file 79.1 used if called from [RA LOCATION PARAMETERS]
+3 if '($DATA(DA)#2)
QUIT
if '$DATA(DIE)
QUIT
+4 NEW RA1,RA2,RA3
SET RA1=0
+5 if DIE["79.1"
DO WARNLOC
+6 IF $ORDER(@(DIE_DA_",""DCM"","_RA1_")"))
WRITE !
+7 FOR
SET RA1=$ORDER(@(DIE_DA_",""DCM"","_RA1_")"))
if 'RA1
QUIT
SET RA2=+^(RA1,0)
SET RA3=$$BASICMOD(RA2,DT)
if +RA3<0
SET RA3=""
WRITE !?6,$PIECE(RA3,"^",2),?9,"(",$PIECE($PIECE(RA3,"^",3)," "),")"
+8 QUIT
EHDP ; EXECUTABLE HELP for DEFAULT CPT MODIFIERS (PROC)
+1 NEW RATXT
+2 SET RATXT(1)=" Choose a CPT Modifier that should be automatically stuffed"
+3 SET RATXT(2)=" into the exam record with this procedure, during exam"
+4 SET RATXT(3)=" registration."
+5 SET RATXT(4)=" "
+6 DO EN^DDIOL(.RATXT)
+7 QUIT
EHDL ; EXECUTABLE HELP for DEFAULT CPT MODIFIERS (LOC)
+1 DO WARNLOC
+2 NEW RATXT
+3 SET RATXT(1)=" Choose a CPT Modifier that should be automatically stuffed"
+4 SET RATXT(2)=" into the exam record, when the following 2 conditions"
+5 SET RATXT(3)=" are both met :"
+6 SET RATXT(4)=" 1-There is no default CPT Modifier for this exam's procedure."
+7 SET RATXT(5)=" 2-This location is the current sign-on (or switched-to) location"
+8 SET RATXT(6)=" at the time of registration."
+9 SET RATXT(7)=" If your entry is invalid, then during exam registration, this"
+10 SET RATXT(8)=" Default CPT Modifier will NOT be stuffed, instead, an error message"
+11 SET RATXT(9)=" with the name of the rejected CPT Modifier would be displayed."
+12 SET RATXT(10)=" "
+13 DO EN^DDIOL(.RATXT)
+14 QUIT
WARNLOC NEW RATXT
+1 SET RATXT(1)=" +----------------------------------------------------------------+"
+2 SET RATXT(2)=" | Your entry cannot be compared with a CPT CODE, so be very sure |"
+3 SET RATXT(3)=" | that this is the Default CPT Modifier that you want to stuff |"
+4 SET RATXT(4)=" | into every registered exam from this imaging location. |"
+5 SET RATXT(5)=" +----------------------------------------------------------------+"
+6 DO EN^DDIOL(.RATXT)
+7 QUIT
