RAUTL17 ;HISC/DAD-RAD/NUC MED COMMON PROCEDURE FILE (#71.3) UTILITIES ;19 Apr 2019 3:32 PM
;;5.0;Radiology/Nuclear Medicine;**158**;Mar 16, 1998;Build 2
EN1 ; *** Get an imaging type
; Input: None
; Output: The variable 'Y' will be one of the following
; -1 = No imaging type selected (up-arrow, time-out, etc.)
; 0 = No active imaging types found
; IEN = IMAGING TYPE file (#79.2) IEN
N DIC,RAI,RAIMGTYI,X
; *** Get active imaging types (must have at least one imaging
; location and at least one procedure to be active)
S (RAI,RAIMGTYI)=0
F S RAIMGTYI=$O(^RA(79.2,RAIMGTYI)) Q:RAIMGTYI'>0 D
. I $O(^RAMIS(71,"AIMG",RAIMGTYI,0)),$O(^RA(79.1,"BIMG",RAIMGTYI,0)) D
.. S RAIMGTYI(RAIMGTYI)=1
.. Q
. Q
S RAIMGTYI=+$O(RAIMGTYI(0))
; *** No active imaging types
I RAIMGTYI'>0 D S Y=0 G EN1EXIT
. W !!?5,"No 'active' imaging types were found. For an imaging"
. W !?5,"type to be active it must be assigned to at least one"
. W !?5,"imaging location and at least one procedure."
. Q
; *** Only one active imaging type
I $O(RAIMGTYI(RAIMGTYI))'>0 S Y=RAIMGTYI G EN1EXIT
; *** display the imaging types available for selection
W !,"Select one of the following imaging types:"
F S RAI=$O(RAIMGTYI(RAI)) Q:RAI'>0 W !?3,$$GET1^DIQ(79.2,RAI_",",.01)
; *** Prompt for active imaging type
K DIC S DIC="^RA(79.2,",DIC(0)="AEMQ",DIC("A")="Select IMAGING TYPE: "
S DIC("S")="I $G(RAIMGTYI(+Y))"
W ! D ^DIC S Y=+Y
EN1EXIT Q
;
EN2(RAIMGTYI,RA71) ; *** Common procedure file error check
; Input: RAIMGTYI = IMAGING TYPE file (#79.2) IEN
; RA71 = PROCEDURE file (#71) IEN (Optional)
; Output: Number_of_Common_Proccedures ^ $S(Duplicate_Sequence#:1,1:0)
;
N RA713,RACNT,RAD0,RADUP,RASEQ
S (RASEQ,RACNT,RADUP)=0
F S RASEQ=$O(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ)) Q:RASEQ'>0 D
. S RA713=0
. F S RA713=$O(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RA713)) Q:RA713'>0 D
.. S RACNT=RACNT+1 I $G(RASEQ(RASEQ)) S RADUP=1
.. S RASEQ(RASEQ)=$S($G(RASEQ(RASEQ)):RASEQ(RASEQ)_U,1:"")_RA713
.. Q
. Q
I $G(RA71),RADUP'>0 D
. S RA713=0 K RASEQ
. F S RA713=$O(^RAMIS(71.3,"B",RA71,RA713)) Q:RA713'>0 D
.. S RA713(0)=$G(^RAMIS(71.3,RA713,0)),RASEQ=$P(RA713(0),U,4)
.. I RASEQ S RASEQ(RASEQ)=""
.. Q
. S RASEQ=0
. F S RASEQ=$O(RASEQ(RASEQ)) Q:RASEQ'>0!RADUP D
.. I $O(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,0)) S RADUP=1
.. Q
. Q
Q RACNT_U_RADUP
;
EN3(D0) ; *** imaging type of a procedure
; Input: RAD/NUC MED PROCEDURE file (#71) IEN
; Output: IMAGING TYPE file (#79.2) IEN
Q +$P($G(^RAMIS(71,+D0,0)),U,12)
;
EN5(RAD0,RAIMGTYI,RASEQ,SK) ; *** Update ^RAMIS(71.3,"AA", xref
; Input: RAD0 = RAD/NUC MED COMMON PROCEDURE file (#71.3) IEN
; RAPRC = PROCEDURE file (#71) IEN
; RASEQ = Sequence number
; SK = Set/Kill flag: $S(SK="S":Set_xref,SK="K":Kill_xref)
I (RASEQ'>0)!(RAIMGTYI'>0) Q
I SK="S" S ^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)=""
I SK="K" K ^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)
Q
;
EN6(RAIMGTYI,RA71) ; *** Common procedure file error messages
;Invoked when .01 field of file 71.3 is edited, allowing the user
;to change the procedure that the .01 field points to
; Input: RAIMGTYI = IMAGING TYPE file (#79.2) IEN
; RA71 = PROCEDURE file (#71) IEN
N RA,RACNT,RADUP
S RA=$$EN2(RAIMGTYI,RA71),RACNT=$P(RA,U),RADUP=$P(RA,U,2)
I RACNT>40!RADUP D K X
. N RATXT
. S RATXT(1)=""
. S RATXT(2)="Changing/ADDING this procedure would cause the following"
. S RATXT(3)="problem(s) in the Rad/Nuc Med Common Procedure file:"
. S RATXT(4)=""
. I RACNT>40 S RATXT(10)=" More than 40 common procedures with the same imaging type."
. I RADUP S RATXT(20)=" Two or more procedures with the same sequence number."
. S RATXT(30)=""
. S RATXT(31)="In order to change this procedure you must first"
. S RATXT(32)="inactivate it in the Rad/Nuc Med Common Procedure file."
. S RATXT(33)=""
. D EN^DDIOL(.RATXT)
. Q
Q
DESC(RAD0,RAY) ; Detemine if a procedure qualifies as a descendent for this
; parent procedure. Descendent must be either a detailed or series
; type procedure, must be of same imaging type of the parent, and must
; not be inactive. Called from ^DD(71.05,.01,0)
; 'RAD0' ien of parent procedure in file 71
; 'RAY' ien of pointed to procedure in file 71
; Returns: 'RA' i.e, 0:invalid procedure, 1:valid procedure
; RAPARNT: zero node of parent procedure
; RAPARNT(12): i-type of parent procedure
; RADESC : zero node of descendent procedure
; RADESC("I"): inactivation date (if any) of descendent
; RADESC(6) : procedure type of descendent
; RADESC(12) : i-type of descendent procedure
Q:RAD0'>0!(RAY'>0) 0
Q:'$D(^RAMIS(71,RAD0,0))!('$D(^RAMIS(71,RAY,0))) 0
N RA,RAI,RADESC,RAPARNT S RA=0
S RAPARNT=$G(^RAMIS(71,RAD0,0)),RAPARNT(12)=+$P(RAPARNT,U,12)
S RADESC=$G(^RAMIS(71,RAY,0)),RADESC(6)=$P(RADESC,U,6)
S RADESC(12)=$P(RADESC,U,12)
S RADESC("I")=+$G(^RAMIS(71,RAY,"I"))
S RAI=$S(RADESC("I")=0:1,RADESC("I")>DT:1,1:0)
I RADESC(12)=RAPARNT(12),("^D^S^"[(U_RADESC(6)_U)),(RAI) S RA=1
Q RA
;
EN713(RAX) ;is this procedure from file 71 already a common procedure?
;RAX = PROCEDURE [.01] field value from 71.3 (ptr to file 71)
;
;returns 1 if the PROCEDURE field value is not a duplicate, else 0
Q:+$O(^RAMIS(71.3,"B",+RAX,0))=0 1
D EN^DDIOL("`"_$P($G(^RAMIS(71,+RAX,0)),"^")_"' already exists as a Common Procedure.")
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL17 5519 printed Apr 09, 2024@21:38:53 Page 2
RAUTL17 ;HISC/DAD-RAD/NUC MED COMMON PROCEDURE FILE (#71.3) UTILITIES ;19 Apr 2019 3:32 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**158**;Mar 16, 1998;Build 2
EN1 ; *** Get an imaging type
+1 ; Input: None
+2 ; Output: The variable 'Y' will be one of the following
+3 ; -1 = No imaging type selected (up-arrow, time-out, etc.)
+4 ; 0 = No active imaging types found
+5 ; IEN = IMAGING TYPE file (#79.2) IEN
+6 NEW DIC,RAI,RAIMGTYI,X
+7 ; *** Get active imaging types (must have at least one imaging
+8 ; location and at least one procedure to be active)
+9 SET (RAI,RAIMGTYI)=0
+10 FOR
SET RAIMGTYI=$ORDER(^RA(79.2,RAIMGTYI))
if RAIMGTYI'>0
QUIT
Begin DoDot:1
+11 IF $ORDER(^RAMIS(71,"AIMG",RAIMGTYI,0))
IF $ORDER(^RA(79.1,"BIMG",RAIMGTYI,0))
Begin DoDot:2
+12 SET RAIMGTYI(RAIMGTYI)=1
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 SET RAIMGTYI=+$ORDER(RAIMGTYI(0))
+16 ; *** No active imaging types
+17 IF RAIMGTYI'>0
Begin DoDot:1
+18 WRITE !!?5,"No 'active' imaging types were found. For an imaging"
+19 WRITE !?5,"type to be active it must be assigned to at least one"
+20 WRITE !?5,"imaging location and at least one procedure."
+21 QUIT
End DoDot:1
SET Y=0
GOTO EN1EXIT
+22 ; *** Only one active imaging type
+23 IF $ORDER(RAIMGTYI(RAIMGTYI))'>0
SET Y=RAIMGTYI
GOTO EN1EXIT
+24 ; *** display the imaging types available for selection
+25 WRITE !,"Select one of the following imaging types:"
+26 FOR
SET RAI=$ORDER(RAIMGTYI(RAI))
if RAI'>0
QUIT
WRITE !?3,$$GET1^DIQ(79.2,RAI_",",.01)
+27 ; *** Prompt for active imaging type
+28 KILL DIC
SET DIC="^RA(79.2,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select IMAGING TYPE: "
+29 SET DIC("S")="I $G(RAIMGTYI(+Y))"
+30 WRITE !
DO ^DIC
SET Y=+Y
EN1EXIT QUIT
+1 ;
EN2(RAIMGTYI,RA71) ; *** Common procedure file error check
+1 ; Input: RAIMGTYI = IMAGING TYPE file (#79.2) IEN
+2 ; RA71 = PROCEDURE file (#71) IEN (Optional)
+3 ; Output: Number_of_Common_Proccedures ^ $S(Duplicate_Sequence#:1,1:0)
+4 ;
+5 NEW RA713,RACNT,RAD0,RADUP,RASEQ
+6 SET (RASEQ,RACNT,RADUP)=0
+7 FOR
SET RASEQ=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ))
if RASEQ'>0
QUIT
Begin DoDot:1
+8 SET RA713=0
+9 FOR
SET RA713=$ORDER(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RA713))
if RA713'>0
QUIT
Begin DoDot:2
+10 SET RACNT=RACNT+1
IF $GET(RASEQ(RASEQ))
SET RADUP=1
+11 SET RASEQ(RASEQ)=$SELECT($GET(RASEQ(RASEQ)):RASEQ(RASEQ)_U,1:"")_RA713
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 IF $GET(RA71)
IF RADUP'>0
Begin DoDot:1
+15 SET RA713=0
KILL RASEQ
+16 FOR
SET RA713=$ORDER(^RAMIS(71.3,"B",RA71,RA713))
if RA713'>0
QUIT
Begin DoDot:2
+17 SET RA713(0)=$GET(^RAMIS(71.3,RA713,0))
SET RASEQ=$PIECE(RA713(0),U,4)
+18 IF RASEQ
SET RASEQ(RASEQ)=""
+19 QUIT
End DoDot:2
+20 SET RASEQ=0
+21 FOR
SET RASEQ=$ORDER(RASEQ(RASEQ))
if RASEQ'>0!RADUP
QUIT
Begin DoDot:2
+22 IF $ORDER(^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,0))
SET RADUP=1
+23 QUIT
End DoDot:2
+24 QUIT
End DoDot:1
+25 QUIT RACNT_U_RADUP
+26 ;
EN3(D0) ; *** imaging type of a procedure
+1 ; Input: RAD/NUC MED PROCEDURE file (#71) IEN
+2 ; Output: IMAGING TYPE file (#79.2) IEN
+3 QUIT +$PIECE($GET(^RAMIS(71,+D0,0)),U,12)
+4 ;
EN5(RAD0,RAIMGTYI,RASEQ,SK) ; *** Update ^RAMIS(71.3,"AA", xref
+1 ; Input: RAD0 = RAD/NUC MED COMMON PROCEDURE file (#71.3) IEN
+2 ; RAPRC = PROCEDURE file (#71) IEN
+3 ; RASEQ = Sequence number
+4 ; SK = Set/Kill flag: $S(SK="S":Set_xref,SK="K":Kill_xref)
+5 IF (RASEQ'>0)!(RAIMGTYI'>0)
QUIT
+6 IF SK="S"
SET ^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)=""
+7 IF SK="K"
KILL ^RAMIS(71.3,"AA",RAIMGTYI,RASEQ,RAD0)
+8 QUIT
+9 ;
EN6(RAIMGTYI,RA71) ; *** Common procedure file error messages
+1 ;Invoked when .01 field of file 71.3 is edited, allowing the user
+2 ;to change the procedure that the .01 field points to
+3 ; Input: RAIMGTYI = IMAGING TYPE file (#79.2) IEN
+4 ; RA71 = PROCEDURE file (#71) IEN
+5 NEW RA,RACNT,RADUP
+6 SET RA=$$EN2(RAIMGTYI,RA71)
SET RACNT=$PIECE(RA,U)
SET RADUP=$PIECE(RA,U,2)
+7 IF RACNT>40!RADUP
Begin DoDot:1
+8 NEW RATXT
+9 SET RATXT(1)=""
+10 SET RATXT(2)="Changing/ADDING this procedure would cause the following"
+11 SET RATXT(3)="problem(s) in the Rad/Nuc Med Common Procedure file:"
+12 SET RATXT(4)=""
+13 IF RACNT>40
SET RATXT(10)=" More than 40 common procedures with the same imaging type."
+14 IF RADUP
SET RATXT(20)=" Two or more procedures with the same sequence number."
+15 SET RATXT(30)=""
+16 SET RATXT(31)="In order to change this procedure you must first"
+17 SET RATXT(32)="inactivate it in the Rad/Nuc Med Common Procedure file."
+18 SET RATXT(33)=""
+19 DO EN^DDIOL(.RATXT)
+20 QUIT
End DoDot:1
KILL X
+21 QUIT
DESC(RAD0,RAY) ; Detemine if a procedure qualifies as a descendent for this
+1 ; parent procedure. Descendent must be either a detailed or series
+2 ; type procedure, must be of same imaging type of the parent, and must
+3 ; not be inactive. Called from ^DD(71.05,.01,0)
+4 ; 'RAD0' ien of parent procedure in file 71
+5 ; 'RAY' ien of pointed to procedure in file 71
+6 ; Returns: 'RA' i.e, 0:invalid procedure, 1:valid procedure
+7 ; RAPARNT: zero node of parent procedure
+8 ; RAPARNT(12): i-type of parent procedure
+9 ; RADESC : zero node of descendent procedure
+10 ; RADESC("I"): inactivation date (if any) of descendent
+11 ; RADESC(6) : procedure type of descendent
+12 ; RADESC(12) : i-type of descendent procedure
+13 if RAD0'>0!(RAY'>0)
QUIT 0
+14 if '$DATA(^RAMIS(71,RAD0,0))!('$DATA(^RAMIS(71,RAY,0)))
QUIT 0
+15 NEW RA,RAI,RADESC,RAPARNT
SET RA=0
+16 SET RAPARNT=$GET(^RAMIS(71,RAD0,0))
SET RAPARNT(12)=+$PIECE(RAPARNT,U,12)
+17 SET RADESC=$GET(^RAMIS(71,RAY,0))
SET RADESC(6)=$PIECE(RADESC,U,6)
+18 SET RADESC(12)=$PIECE(RADESC,U,12)
+19 SET RADESC("I")=+$GET(^RAMIS(71,RAY,"I"))
+20 SET RAI=$SELECT(RADESC("I")=0:1,RADESC("I")>DT:1,1:0)
+21 IF RADESC(12)=RAPARNT(12)
IF ("^D^S^"[(U_RADESC(6)_U))
IF (RAI)
SET RA=1
+22 QUIT RA
+23 ;
EN713(RAX) ;is this procedure from file 71 already a common procedure?
+1 ;RAX = PROCEDURE [.01] field value from 71.3 (ptr to file 71)
+2 ;
+3 ;returns 1 if the PROCEDURE field value is not a duplicate, else 0
+4 if +$ORDER(^RAMIS(71.3,"B",+RAX,0))=0
QUIT 1
+5 DO EN^DDIOL("`"_$PIECE($GET(^RAMIS(71,+RAX,0)),"^")_"' already exists as a Common Procedure.")
+6 QUIT 0
+7 ;
