RAMAIN2 ;HISC/GJC - Radiology Utility File Maintenance (Part Two) ; May 31, 2024@14:28:03
;;5.0;Radiology/Nuclear Medicine;**45,62,71,65,127,138,158,208,214**;Mar 16, 1998;Build 1
; 08/12/2005 bay/kam Remedy Call 104630 Patch 62
; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71
;
;Supported IA #10141 reference to MES^XPDUTL
;Supported IA #10142 reference to EN^DDIOL
;Supported IA #10103 reference to DT^XLFDT
;
;*** start of RA5p208 updates ***
;*** start of RA5p214 updates *** 05/06/2024
2 ;;Procedure Enter/Edit
; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. ***
; RA PROCEDURE option.
F S RAY214=0 DO PRCEE Q:+$G(RAY214)=-1
; kill and quit... Note: leave all the package
;wide variables setup at sign-on
;-------------------------------
; RACCESS array, RAIMGTY
; RAMDIV, RAMDV & RAMLC
;kill option variables on way out...
D KILLPRCEE K %DT,DILN,DIWT,DN,DUOUT,DTOUT,DIRUT,DIROUT
D VALIDITY ;run once for ALL procedures entered/edited
Q ;'Procedure Enter/Edit' option exit
;*** end of RA5p214 updates *** 05/06/2024
;
PRCEE ;PROCEDURE ENTER/EDIT subroutine
;kill key option variables inside loop
D KILLPRCEE
;K RADA,RACTIVE,RAENALL,RAEXC,RAF71,RAY,RAFILE,RASTAT,RAXIT,RAIEN,RANEW,RANEW71
;K DA,J,RACMDIFF,RAOPTYP,RARMPF,RATRKCMA,RATRKCMB,RAY214,X,Y
S (RAENALL,RANEW71,RAXIT,RANEW)=0 K ^XTMP("RAMAIN4",$J)
N RADIO,RAPNM,RAPTY,RAASK,RAROUTE ;used by the edit template
;F D Q:$G(RAXIT)=0!($G(RAXIT)="")!($G(^XTMP("RAMAIN4",$J,"RAEND"))=1) G:$G(^XTMP("RAMAIN4",$J,"RAEND"))=1 END
;K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB
S DIC="^RAMIS(71,",DIC(0)="QEAMLZ",DLAYGO=71,DIC("DR")=6
W ! D ^DIC K D,DD,DIC,DINUM,DLAYGO,DO S RAY214=$G(Y) ;RA5p214 namespace!
Q:+Y=-1 ;-1 no selection - exit
;I $G(Y)<0!($G(Y)="") S ^XTMP("RAMAIN4",$J,"RAEND")=1 Q
S (DA,RADA)=+Y,RAY=Y,RAFILE=71
S RAPNM=$G(Y(0,0)) ;proc. name for display purposes in template
;RA*5*71 changed next line for Remedy Call 131482
S RANEW71=$S($P(Y,U,3)=1:1,1:0) ;used in template, edit CPT Code if new rec.
L +^RAMIS(RAFILE,RADA):5
I '$T D Q
.W !?5,"This record is currently being edited by another user."
.W !?5,"Try again later!",$C(7) S RAXIT=1
.Q
21 ;ENTRY POINT FROM RANPRO, RA*5.0*127 (de-activation of LOINC) RA5p208
;S (RAENALL,RANEW71,RAXIT,RANEW)=0 S:$G(RACTIVE)="" RACTIVE="" K ^XTMP("RAMAIN4",$J)
S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
S:$G(RASTAT)="" RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0) ;<-- RAY & RAFILE set above. RA5P208
S RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing
; CM definition before editing. RATRKCMB ids the before CM values
;I $G(RANEW)=1 Q ;RA*50*127 NEW PROCEDURE <- commented out w/RA5p208
S DIE="^RAMIS(71,",DR="[RA PROCEDURE EDIT]" D ^DIE
S RACPT=$P(^RAMIS(71,RADA,0),U,9)
K RAPNM S RAPROC(0)=$G(^RAMIS(71,RADA,0))
;
;check for data consistency between the 'CONTRAST MEDIA USED' &
;'CONTRAST MEDIA' fields.
D CMINTEG^RAMAINU1(RADA,RAPROC(0))
;
D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA)
S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^")
S RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line
I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),'+$G(RANEW71) D
.K %,C,D0,DE,DI,DIE,DQ,DR
.W !?5,$C(7),"...no CPT code entered..."
.W !?5,"...will change type to a 'broad' procedure.",!
.S DA=RADA,DIE="^RAMIS(71,",DR="6///B" D ^DIE
.Q
;08/12/2005 104630 - KAM added next 5 lines
I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)),+$G(RANEW71) D
.K %,C,D0,DE,DI,DIK,DQ,DR
.W !?5,$C(7),"...no CPT code entered..."
.W !?5,"...will delete the record at this time.",!
.S DIK="^RAMIS(71,",DA=RADA D ^DIK K DIK
;if an active parent w/o descendants, inactivate the parent
I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D
.K D,D0,D1,DA,DI,DIC,DIE,DQ,DR
.W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7)
.S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT())
.D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive
.Q
I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA)
I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D
.K %,D,D0,DA,DE,DIC,DIE,DQ,DR
.S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE
.W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7)
.Q
K %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y
;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41)
;file exists unconditionally
D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
;
L -^RAMIS(RAFILE,RADA)
;unconditionally update the parent procedure if the descendent
I $O(^RAMIS(71,"ADESC",+RAY,0)) D UPDATP^RAO7UTL(RAY)
;has been edited
;commented out w/RA5p208 BEGIN
;I $G(RANEW)=1 D EN^RANPRO(RAYY,RATYPE,RANEW) ;RA*5.0*127 NEW PROCEDURE
;K DIR,RACMDIFF,RATRKCMA,RATRKCMB
;I $G(^XTMP("RAMAIN4",$J,"RAEND"))=1 G END
;D EXIT G END
;Q
QUIT ;create VALIDITY subroutine RA5P214.
;
VALIDITY ;Running validity check on CPT and stop codes.
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="YAO",DIR("B")="NO"
S DIR("A")="Want to run a validity check on CPT and stop codes? "
S DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures"
S DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)."
S DIR("?",3)="Broad procedures with invalid codes are included for information"
S DIR("?",4)="only. Inactive procedures are not required to have valid codes."
S DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;"
S DIR("?",6)="CPT's must be nationally active."
S DIR("?")="Please answer 'YES' or 'NO'."
W ! D ^DIR K DIR Q:$D(DIRUT)#2
D:Y ^RAPERR
Q
; *** end of RA5p208 updates ***
;
13 ;;Rad/Nuc Med Common Procedure File Enter/Edit
; RA COMMON PROCEDURE option RA5P158
N RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI S RAENALL=0
W ! D EN1^RAUTL17 G:Y'>0 Q13 S RAIMGTYI=Y
131 S DIC="^RAMIS(71.3,",DIC(0)="AELMQZ",DLAYGO=71.3
S DIC("S")="I $$SCRN713^RAMAIN2(+$P(^(0),U),RAIMGTYI)"
S DIC("W")="W $$DICW713^RAMAIN2($P($G(^(0)),U,4))"
W ! D ^DIC K DIC,DLAYGO,D,X
I Y<0 D Q13 G RESEQ
; If a sequence # exists, the Common Proc. is active
MERGE RAY=Y S RADA=+Y,RAFILE=71.3 L +^RAMIS(RAFILE,RADA):5
I '$T D G Q13
. W !?5,"This record is currently being edited by another user."
. W !?5,"Try again later!",$C(7)
. Q
S RASTAT=$S($P(Y(0),"^",4)]"":1,1:0)_"^"
I '+$P(RASTAT,"^") S RALOW=$$LOW(RAIMGTYI)
S DA=RADA,DIE="^RAMIS(71.3,",DR="[RA COMMON PROCEDURE EDIT]" D ^DIE
S RAMIS713(0)=$G(^RAMIS(71.3,RADA,0))
; If the procedure is different than the one originally selected and
; the CPRS Order Dialog file exists, send the Orderable Item Update
; message to CPRS.
I $P(RAMIS713(0),"^")'=$P(RAY,"^",2),($$ORQUIK^RAORDU()=1) D
. S RASTAT=RASTAT_0 D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
. S RAY=RADA_"^"_$P($G(^RAMIS(71.3,RADA,0)),"^")_"^"_1,RASTAT=0_"^"
. Q
K %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y
S RASTAT=RASTAT_$S($P($G(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0)
; If before & after statuses differ, and the CPRS Order Dialog file
; exists, send the Orderable Item Update message to CPRS.
I $$ORQUIK^RAORDU()=1,(($P(RASTAT,"^")+$P(RASTAT,"^",2))=1) D
. D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
. Q
L -^RAMIS(RAFILE,RADA)
G 131
Q13 K DDC,DDH,DISYS,I,POP,RA713
Q
RESEQ ;Resequence the common procedure list
N D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X
I $D(XPDNM) D ; if called during package install
. S TXT(1)=" "
. S TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List."
. Q
E W !!?5,"Resequencing the Rad/Nuc Med Common Procedure List"
S DIE="^RAMIS(71.3,",(I,CNT)=0
F S I=$O(^RAMIS(71.3,"AA",RAIMGTYI,I)) Q:I'>0 D
. S J=0
. F S J=$O(^RAMIS(71.3,"AA",RAIMGTYI,I,J)) Q:J'>0 I $D(^RAMIS(71.3,J,0)) D
.. S DA=J,CNT=CNT+1 N I,J
.. S DR="3////^S X=CNT" D ^DIE W:'$D(XPDNM) "."
.. Q
. Q
I $D(XPDNM) D ; if called during package install
. S TXT(2)=$G(TXT(2))_" Done!"
. D MES^XPDUTL(.TXT)
. Q
E W " Done!"
Q
LOW(X) ; Find the lowest available sequence number for a procedure within
; a specific Imaging Type. Seq. #'s range from 1 to 40. If the
; range changes in the DD i.e, ^DD(71.3,3, this code as well as the
; code if EN3^RAUTL18 must also be altered.
; If RAHIT is passed back as "", there is no available sequence number.
N RA,RAHIT S RAHIT=""
F RA=1:1:40 D Q:RAHIT
. Q:$D(^RAMIS(71.3,"AA",X,RA))
. S:RAHIT="" RAHIT=RA
. Q
Q RAHIT
VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha-
; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult
; Dose' & 'High Adult Dose' range. This subroutine will display the
; Radiopharmaceutical in question along with the values in question if
; inconsistencies are found.
;
; Input Variable: 'RADA' the ien of the Procedure
N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!")
F S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0 D
. S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
. Q:$P(RANUC(0),"^",2)="" ; no need to validate, nothing input
. I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D
.. N RARRY S RARRY(1)="For Radiopharmaceutical: "
.. S RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$P(RANUC(0),"^"),.01)_$C(7)
.. S RARRY(2)="" D EN^DDIOL(.RARRY,"")
.. Q
. Q
Q
DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple
N RADA1 S RADA1=0
W !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
F S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0 D
. K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
. S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC"","
. S DR=".01///@" D ^DIE
. Q
K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
Q
;
END ;KILL LOGIC AND END ROUTINE
K RACODE,RACPT,RAGOLD,RAMATCH,RANEW71,RANM,RAPROIEN,RATYPE,RAYY
K DDC,DDH,DISYS,I,POP,RA713,DIK,DA
Q
;
SCRN713(Y,RAIMGTYI) ;screen common procedures by i-type
;RAIMGTYI set above in 13^RAMAIN2
;'Y' = the IEN of the common procedure as it exists in file 71
;'RAIMGTYI' = IEN of the imaging type for the common procedure
QUIT:(RAIMGTYI=$P($G(^RAMIS(71,Y,0)),U,12)) 1
Q 0
;
DICW713(RAX) ;display the sequence number or a message is the sequence
;number is missing. ^DD(71.3,3,0)="SEQUENCE NUMBER" 0;4
;'RAX' the sequence number or null statement
N RASEQTXT S RASEQTXT=" "_$S(RAX>0:"("_RAX_")",1:"(no sequence number)")
Q RASEQTXT
;
KILLPRCEE ;kill procedure enter/edit variables... RA5P214
;note: vars RAF71,RARMPF,RAOPTYP,RAEXC & RABINARY are also killed at the end of the
;RA PROCEDURE EDIT input template. Killing them here b/c exiting RA PROCEDURE EDIT
;before stepping through to the end leaves some/all of those vars defined.
K DA,RADA,RACTIVE,RAENALL,RAEXC,RARMPF,RAF71,RAY,RAFILE,RASTAT,RAXIT,RAIEN,RANEW,RANEW71
K %DT,DILN,DIWT,DN,DUOUT,J,RABINARY,RACMDIFF,RAOPTYP,RATRKCMA,RATRKCMB,RAY214,X,Y
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAIN2 11369 printed Nov 22, 2024@17:47:11 Page 2
RAMAIN2 ;HISC/GJC - Radiology Utility File Maintenance (Part Two) ; May 31, 2024@14:28:03
+1 ;;5.0;Radiology/Nuclear Medicine;**45,62,71,65,127,138,158,208,214**;Mar 16, 1998;Build 1
+2 ; 08/12/2005 bay/kam Remedy Call 104630 Patch 62
+3 ; 03/02/2006 BAY/KAM Remedy Call 131482 Patch RA*5*71
+4 ;
+5 ;Supported IA #10141 reference to MES^XPDUTL
+6 ;Supported IA #10142 reference to EN^DDIOL
+7 ;Supported IA #10103 reference to DT^XLFDT
+8 ;
+9 ;*** start of RA5p208 updates ***
+10 ;*** start of RA5p214 updates *** 05/06/2024
2 ;;Procedure Enter/Edit
+1 ; *** This subroutine once resided in RAMAIN i.e, '2^RAMAIN'. ***
+2 ; RA PROCEDURE option.
+3 FOR
SET RAY214=0
DO PRCEE
if +$GET(RAY214)=-1
QUIT
+4 ; kill and quit... Note: leave all the package
+5 ;wide variables setup at sign-on
+6 ;-------------------------------
+7 ; RACCESS array, RAIMGTY
+8 ; RAMDIV, RAMDV & RAMLC
+9 ;kill option variables on way out...
+10 DO KILLPRCEE
KILL %DT,DILN,DIWT,DN,DUOUT,DTOUT,DIRUT,DIROUT
+11 ;run once for ALL procedures entered/edited
DO VALIDITY
+12 ;'Procedure Enter/Edit' option exit
QUIT
+13 ;*** end of RA5p214 updates *** 05/06/2024
+14 ;
PRCEE ;PROCEDURE ENTER/EDIT subroutine
+1 ;kill key option variables inside loop
+2 DO KILLPRCEE
+3 ;K RADA,RACTIVE,RAENALL,RAEXC,RAF71,RAY,RAFILE,RASTAT,RAXIT,RAIEN,RANEW,RANEW71
+4 ;K DA,J,RACMDIFF,RAOPTYP,RARMPF,RATRKCMA,RATRKCMB,RAY214,X,Y
+5 SET (RAENALL,RANEW71,RAXIT,RANEW)=0
KILL ^XTMP("RAMAIN4",$JOB)
+6 ;used by the edit template
NEW RADIO,RAPNM,RAPTY,RAASK,RAROUTE
+7 ;F D Q:$G(RAXIT)=0!($G(RAXIT)="")!($G(^XTMP("RAMAIN4",$J,"RAEND"))=1) G:$G(^XTMP("RAMAIN4",$J,"RAEND"))=1 END
+8 ;K DA,DD,DIC,DINUM,DLAYGO,DO,RACMDIFF,RATRKCMA,RATRKCMB
+9 SET DIC="^RAMIS(71,"
SET DIC(0)="QEAMLZ"
SET DLAYGO=71
SET DIC("DR")=6
+10 ;RA5p214 namespace!
WRITE !
DO ^DIC
KILL D,DD,DIC,DINUM,DLAYGO,DO
SET RAY214=$GET(Y)
+11 ;-1 no selection - exit
if +Y=-1
QUIT
+12 ;I $G(Y)<0!($G(Y)="") S ^XTMP("RAMAIN4",$J,"RAEND")=1 Q
+13 SET (DA,RADA)=+Y
SET RAY=Y
SET RAFILE=71
+14 ;proc. name for display purposes in template
SET RAPNM=$GET(Y(0,0))
+15 ;RA*5*71 changed next line for Remedy Call 131482
+16 ;used in template, edit CPT Code if new rec.
SET RANEW71=$SELECT($PIECE(Y,U,3)=1:1,1:0)
+17 LOCK +^RAMIS(RAFILE,RADA):5
+18 IF '$TEST
Begin DoDot:1
+19 WRITE !?5,"This record is currently being edited by another user."
+20 WRITE !?5,"Try again later!",$CHAR(7)
SET RAXIT=1
+21 QUIT
End DoDot:1
QUIT
21 ;ENTRY POINT FROM RANPRO, RA*5.0*127 (de-activation of LOINC) RA5p208
+1 ;S (RAENALL,RANEW71,RAXIT,RANEW)=0 S:$G(RACTIVE)="" RACTIVE="" K ^XTMP("RAMAIN4",$J)
+2 SET RACTIVE=$PIECE($GET(^RAMIS(71,RADA,"I")),"^")
+3 ;<-- RAY & RAFILE set above. RA5P208
if $GET(RASTAT)=""
SET RASTAT=$SELECT(RACTIVE="":1,RACTIVE>DT:1,1:0)
+4 SET RASTAT=$SELECT(RACTIVE="":1,RACTIVE>DT:1,1:0)
+5 ;tracks existing
DO TRKCMB^RAMAINU(DA,.RATRKCMB)
+6 ; CM definition before editing. RATRKCMB ids the before CM values
+7 ;I $G(RANEW)=1 Q ;RA*50*127 NEW PROCEDURE <- commented out w/RA5p208
+8 SET DIE="^RAMIS(71,"
SET DR="[RA PROCEDURE EDIT]"
DO ^DIE
+9 SET RACPT=$PIECE(^RAMIS(71,RADA,0),U,9)
+10 KILL RAPNM
SET RAPROC(0)=$GET(^RAMIS(71,RADA,0))
+11 ;
+12 ;check for data consistency between the 'CONTRAST MEDIA USED' &
+13 ;'CONTRAST MEDIA' fields.
+14 DO CMINTEG^RAMAINU1(RADA,RAPROC(0))
+15 ;
+16 DO TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
+17 IF $ORDER(^RAMIS(71,RADA,"NUC",0))
IF ($PIECE(RAPROC(0),"^",2)=1)
DO DELRADE(RADA)
+18 SET RACTIVE=$PIECE($GET(^RAMIS(71,RADA,"I")),"^")
+19 SET RASTAT=RASTAT_"^"_$SELECT(RACTIVE="":1,RACTIVE>DT:1,1:0)
+20 ; 08/12/2005 104630 KAM - added '$G(RANEW71) to next line
+21 IF RAPROC(0)]""
IF ("^B^P^"'[(U_$PIECE(RAPROC(0),"^",6)_U))
IF ('+$PIECE(RAPROC(0),"^",9))
IF '+$GET(RANEW71)
Begin DoDot:1
+22 KILL %,C,D0,DE,DI,DIE,DQ,DR
+23 WRITE !?5,$CHAR(7),"...no CPT code entered..."
+24 WRITE !?5,"...will change type to a 'broad' procedure.",!
+25 SET DA=RADA
SET DIE="^RAMIS(71,"
SET DR="6///B"
DO ^DIE
+26 QUIT
End DoDot:1
+27 ;08/12/2005 104630 - KAM added next 5 lines
+28 IF RAPROC(0)]""
IF ("^B^P^"'[(U_$PIECE(RAPROC(0),"^",6)_U))
IF ('+$PIECE(RAPROC(0),"^",9))
IF +$GET(RANEW71)
Begin DoDot:1
+29 KILL %,C,D0,DE,DI,DIK,DQ,DR
+30 WRITE !?5,$CHAR(7),"...no CPT code entered..."
+31 WRITE !?5,"...will delete the record at this time.",!
+32 SET DIK="^RAMIS(71,"
SET DA=RADA
DO ^DIK
KILL DIK
End DoDot:1
+33 ;if an active parent w/o descendants, inactivate the parent
+34 IF $PIECE(RASTAT,U,2)
IF ($PIECE(RAPROC(0),U,6)="P")
IF ('$ORDER(^RAMIS(71,RADA,4,0)))
Begin DoDot:1
+35 KILL D,D0,D1,DA,DI,DIC,DIE,DQ,DR
+36 WRITE !!?5,"Inactivating this parent procedure - no descendents.",!,$CHAR(7)
+37 SET DA=RADA
SET DIE="^RAMIS(71,"
SET DR="100///"_$SELECT($DATA(DT):DT,1:$$DT^XLFDT())
+38 ;inactive
DO ^DIE
KILL D,D0,D1,DA,DI,DIC,DIE,DQ,DR
SET $PIECE(RASTAT,U,2)=0
+39 QUIT
End DoDot:1
+40 IF $PIECE($GET(^RA(79.2,+$PIECE(RAPROC(0),U,12),0)),U,5)="Y"
IF (+$ORDER(^RAMIS(71,RADA,"NUC",0)))
DO VRDIO(RADA)
+41 IF "^B^P^"[(U_$PIECE(RAPROC(0),U,6)_U)
IF ($PIECE(RAPROC(0),U,9)]"")
Begin DoDot:1
+42 KILL %,D,D0,DA,DE,DIC,DIE,DQ,DR
+43 SET DA=RADA
SET DIE="^RAMIS(71,"
SET DR="9///@"
DO ^DIE
+44 WRITE !!?5,"...CPT code deleted because "_$SELECT($PIECE(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$CHAR(7)
+45 QUIT
End DoDot:1
+46 KILL %,%X,%Y,C,D,D0,D1,DA,DE,DI,DIE,DQ,DR,RAIMAG,RAMIS,RAPROC,X,Y
+47 ;send Orderable Item HL7 msg to CPRS if the ORDER DIALOG (#101.41)
+48 ;file exists unconditionally
+49 if $$ORQUIK^RAORDU()=1
DO PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
+50 ;
+51 LOCK -^RAMIS(RAFILE,RADA)
+52 ;unconditionally update the parent procedure if the descendent
+53 IF $ORDER(^RAMIS(71,"ADESC",+RAY,0))
DO UPDATP^RAO7UTL(RAY)
+54 ;has been edited
+55 ;commented out w/RA5p208 BEGIN
+56 ;I $G(RANEW)=1 D EN^RANPRO(RAYY,RATYPE,RANEW) ;RA*5.0*127 NEW PROCEDURE
+57 ;K DIR,RACMDIFF,RATRKCMA,RATRKCMB
+58 ;I $G(^XTMP("RAMAIN4",$J,"RAEND"))=1 G END
+59 ;D EXIT G END
+60 ;Q
+61 ;create VALIDITY subroutine RA5P214.
QUIT
+62 ;
VALIDITY ;Running validity check on CPT and stop codes.
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="YAO"
SET DIR("B")="NO"
+3 SET DIR("A")="Want to run a validity check on CPT and stop codes? "
+4 SET DIR("?",1)="Answer 'YES' to print a list of Radiology/Nuclear Medicine Procedures"
+5 SET DIR("?",2)="with missing or invalid CPT's and/or Credit Clinic Stop Code(s)."
+6 SET DIR("?",3)="Broad procedures with invalid codes are included for information"
+7 SET DIR("?",4)="only. Inactive procedures are not required to have valid codes."
+8 SET DIR("?",5)="To be valid, Stop Codes must be in the Imaging Stop Codes file 71.5;"
+9 SET DIR("?",6)="CPT's must be nationally active."
+10 SET DIR("?")="Please answer 'YES' or 'NO'."
+11 WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)#2
QUIT
+12 if Y
DO ^RAPERR
+13 QUIT
+14 ; *** end of RA5p208 updates ***
+15 ;
13 ;;Rad/Nuc Med Common Procedure File Enter/Edit
+1 ; RA COMMON PROCEDURE option RA5P158
+2 NEW RADA,RAENALL,RAY,RAFILE,RALOW,RAMIS713,RASTAT,RAIMGTYI
SET RAENALL=0
+3 WRITE !
DO EN1^RAUTL17
if Y'>0
GOTO Q13
SET RAIMGTYI=Y
131 SET DIC="^RAMIS(71.3,"
SET DIC(0)="AELMQZ"
SET DLAYGO=71.3
+1 SET DIC("S")="I $$SCRN713^RAMAIN2(+$P(^(0),U),RAIMGTYI)"
+2 SET DIC("W")="W $$DICW713^RAMAIN2($P($G(^(0)),U,4))"
+3 WRITE !
DO ^DIC
KILL DIC,DLAYGO,D,X
+4 IF Y<0
DO Q13
GOTO RESEQ
+5 ; If a sequence # exists, the Common Proc. is active
+6 MERGE RAY=Y
SET RADA=+Y
SET RAFILE=71.3
LOCK +^RAMIS(RAFILE,RADA):5
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !?5,"This record is currently being edited by another user."
+9 WRITE !?5,"Try again later!",$CHAR(7)
+10 QUIT
End DoDot:1
GOTO Q13
+11 SET RASTAT=$SELECT($PIECE(Y(0),"^",4)]"":1,1:0)_"^"
+12 IF '+$PIECE(RASTAT,"^")
SET RALOW=$$LOW(RAIMGTYI)
+13 SET DA=RADA
SET DIE="^RAMIS(71.3,"
SET DR="[RA COMMON PROCEDURE EDIT]"
DO ^DIE
+14 SET RAMIS713(0)=$GET(^RAMIS(71.3,RADA,0))
+15 ; If the procedure is different than the one originally selected and
+16 ; the CPRS Order Dialog file exists, send the Orderable Item Update
+17 ; message to CPRS.
+18 IF $PIECE(RAMIS713(0),"^")'=$PIECE(RAY,"^",2)
IF ($$ORQUIK^RAORDU()=1)
Begin DoDot:1
+19 SET RASTAT=RASTAT_0
DO PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
+20 SET RAY=RADA_"^"_$PIECE($GET(^RAMIS(71.3,RADA,0)),"^")_"^"_1
SET RASTAT=0_"^"
+21 QUIT
End DoDot:1
+22 KILL %,%X,%Y,C,D,D0,DA,DE,DI,DIE,DQ,DR,X,Y
+23 SET RASTAT=RASTAT_$SELECT($PIECE($GET(^RAMIS(71.3,+RAY,0)),"^",4)]"":1,1:0)
+24 ; If before & after statuses differ, and the CPRS Order Dialog file
+25 ; exists, send the Orderable Item Update message to CPRS.
+26 IF $$ORQUIK^RAORDU()=1
IF (($PIECE(RASTAT,"^")+$PIECE(RASTAT,"^",2))=1)
Begin DoDot:1
+27 DO PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
+28 QUIT
End DoDot:1
+29 LOCK -^RAMIS(RAFILE,RADA)
+30 GOTO 131
Q13 KILL DDC,DDH,DISYS,I,POP,RA713
+1 QUIT
RESEQ ;Resequence the common procedure list
+1 NEW D,D0,DI,DQ,H,I,J,CNT,DIC,DIE,DR,DA,TXT,X
+2 ; if called during package install
IF $DATA(XPDNM)
Begin DoDot:1
+3 SET TXT(1)=" "
+4 SET TXT(2)="Resequencing the Rad/Nuc Med Common Procedure List."
+5 QUIT
End DoDot:1
+6 IF '$TEST
WRITE !!?5,"Resequencing the Rad/Nuc Med Common Procedure List"
+7 SET DIE="^RAMIS(71.3,"
SET (I,CNT)=0
+8 FOR
SET I=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,I))
if I'>0
QUIT
Begin DoDot:1
+9 SET J=0
+10 FOR
SET J=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,I,J))
if J'>0
QUIT
IF $DATA(^RAMIS(71.3,J,0))
Begin DoDot:2
+11 SET DA=J
SET CNT=CNT+1
NEW I,J
+12 SET DR="3////^S X=CNT"
DO ^DIE
if '$DATA(XPDNM)
WRITE "."
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ; if called during package install
IF $DATA(XPDNM)
Begin DoDot:1
+16 SET TXT(2)=$GET(TXT(2))_" Done!"
+17 DO MES^XPDUTL(.TXT)
+18 QUIT
End DoDot:1
+19 IF '$TEST
WRITE " Done!"
+20 QUIT
LOW(X) ; Find the lowest available sequence number for a procedure within
+1 ; a specific Imaging Type. Seq. #'s range from 1 to 40. If the
+2 ; range changes in the DD i.e, ^DD(71.3,3, this code as well as the
+3 ; code if EN3^RAUTL18 must also be altered.
+4 ; If RAHIT is passed back as "", there is no available sequence number.
+5 NEW RA,RAHIT
SET RAHIT=""
+6 FOR RA=1:1:40
Begin DoDot:1
+7 if $DATA(^RAMIS(71.3,"AA",X,RA))
QUIT
+8 if RAHIT=""
SET RAHIT=RA
+9 QUIT
End DoDot:1
if RAHIT
QUIT
+10 QUIT RAHIT
VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha-
+1 ; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult
+2 ; Dose' & 'High Adult Dose' range. This subroutine will display the
+3 ; Radiopharmaceutical in question along with the values in question if
+4 ; inconsistencies are found.
+5 ;
+6 ; Input Variable: 'RADA' the ien of the Procedure
+7 NEW RANUC
SET RADA(1)=RADA
SET RADA=0
DO EN^DDIOL("","","!")
+8 FOR
SET RADA=$ORDER(^RAMIS(71,RADA(1),"NUC",RADA))
if RADA'>0
QUIT
Begin DoDot:1
+9 SET RANUC(0)=$GET(^RAMIS(71,RADA(1),"NUC",RADA,0))
+10 ; no need to validate, nothing input
if $PIECE(RANUC(0),"^",2)=""
QUIT
+11 IF '$$USUAL^RADD2(.RADA,$PIECE(RANUC(0),"^",2))
Begin DoDot:2
+12 NEW RARRY
SET RARRY(1)="For Radiopharmaceutical: "
+13 SET RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$PIECE(RANUC(0),"^"),.01)_$CHAR(7)
+14 SET RARRY(2)=""
DO EN^DDIOL(.RARRY,"")
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple
+1 NEW RADA1
SET RADA1=0
+2 WRITE !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
+3 FOR
SET RADA1=$ORDER(^RAMIS(71,RADA,"NUC",RADA1))
if RADA1'>0
QUIT
Begin DoDot:1
+4 KILL %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+5 SET DA(1)=RADA
SET DA=RADA1
SET DIE="^RAMIS(71,"_RADA_",""NUC"","
+6 SET DR=".01///@"
DO ^DIE
+7 QUIT
End DoDot:1
+8 KILL %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+9 QUIT
+10 ;
END ;KILL LOGIC AND END ROUTINE
+1 KILL RACODE,RACPT,RAGOLD,RAMATCH,RANEW71,RANM,RAPROIEN,RATYPE,RAYY
+2 KILL DDC,DDH,DISYS,I,POP,RA713,DIK,DA
+3 QUIT
+4 ;
SCRN713(Y,RAIMGTYI) ;screen common procedures by i-type
+1 ;RAIMGTYI set above in 13^RAMAIN2
+2 ;'Y' = the IEN of the common procedure as it exists in file 71
+3 ;'RAIMGTYI' = IEN of the imaging type for the common procedure
+4 if (RAIMGTYI=$PIECE($GET(^RAMIS(71,Y,0)),U,12))
QUIT 1
+5 QUIT 0
+6 ;
DICW713(RAX) ;display the sequence number or a message is the sequence
+1 ;number is missing. ^DD(71.3,3,0)="SEQUENCE NUMBER" 0;4
+2 ;'RAX' the sequence number or null statement
+3 NEW RASEQTXT
SET RASEQTXT=" "_$SELECT(RAX>0:"("_RAX_")",1:"(no sequence number)")
+4 QUIT RASEQTXT
+5 ;
KILLPRCEE ;kill procedure enter/edit variables... RA5P214
+1 ;note: vars RAF71,RARMPF,RAOPTYP,RAEXC & RABINARY are also killed at the end of the
+2 ;RA PROCEDURE EDIT input template. Killing them here b/c exiting RA PROCEDURE EDIT
+3 ;before stepping through to the end leaves some/all of those vars defined.
+4 KILL DA,RADA,RACTIVE,RAENALL,RAEXC,RARMPF,RAF71,RAY,RAFILE,RASTAT,RAXIT,RAIEN,RANEW,RANEW71
+5 KILL %DT,DILN,DIWT,DN,DUOUT,J,RABINARY,RACMDIFF,RAOPTYP,RATRKCMA,RATRKCMB,RAY214,X,Y
+6 QUIT
+7 ;
