RADD2 ;HISC/GJC/CAH-Radiology Data Dictionary Utility Routine ; Feb 11, 2021@11:10:54
;;5.0;Radiology/Nuclear Medicine;**84,47,124,158,175**;Mar 16, 1998;Build 2
;
;Integration Agreements
;----------------------
;EN^DDIOL(10142); FILE^DIE(2053);NOTE^ORX3(868);MES^XPDUTL(10141)
;
EN1(RA71) ; Input transform for the .01 field (Procedure) for the Rad/Nuc
; Med Common Procedure file i.e, ^RAMIS(71.3 (reworked for RA*5.0*158)
; Procedure must not have an inactive date before today in file 71
; Procedure in file 71 must have same imaging type as the one
; selected before editing this record in file 71.3
;
; A PARENT type procedure must have at least one descendent
; Output:
; -If at least one descendant return one
; -else return 0
;
; Input:
; RA71 = IENS of entries in ^RAMIS(71,
; RAIMGTYI = IEN of an IMAGING TYPE record (global scope)
;
Q:'$G(RAIMGTYI) 0
;
S RA71("I")=$G(^RAMIS(71,+RA71,"I")),RA71(0)=$G(^RAMIS(71,+RA71,0))
;parent procedure?
S RAPARENT=$S($P(RA71(0),"^",6)="P":1,1:0)
;does the parent have a descendant?
S:RAPARENT RAPFLG=+$O(^RAMIS(71,+RA71,4,0))
;
;if no "I" node or "I" node null ok, if DT is before today ok, else not ok
S RA71ACTIVE=$S(RA71("I")="":1,DT<RA71("I"):1,1:0)
Q:RA71ACTIVE=0 0
;
;match i-type?
S RA71ITYPE=$S(RAIMGTYI=$P($G(RA71(0)),"^",12):1,1:0)
Q:RA71ITYPE=0 0
;
;if active, w/i-type match & non-parent quit 1
Q:RAPARENT=0 1
;
;if active, w/i-type match & parent w/descendant quit 1
Q:RAPARENT&RAPFLG 1
;
K RA71ACTIVE,RA71ITYPE,RAPARENT,RAPFLG
Q 0
;
CH ;this tag was removed w/RA*5.0*175
Q
;
INACOM(RAD0) ; Check inactive date on the Rad/Nuc Med Procedure file (71)
; for the Common Procedure before setting our inactive procedure to
; active. Called from the 'RA COMMON PROCEDURE EDIT' input template.
; Option: Common Procedure Enter/Edit (13^RAMAIN2)
; Input : RAD0-ien of Rad/Nuc Med Common Procedure
; Output: if Common cannot be re-activated, reset the 'Inactive' field
; to 'yes'.
N RAINA S RAINA=$P($G(^RAMIS(71,+$P($G(^RAMIS(71.3,RAD0,0)),"^"),"I")),"^")
Q:RAINA=""!(RAINA>DT) "@15" ; we can inactivate the common
N RAFDA,RAMSG
S RAFDA(71.3,RAD0_",",4)="Y" D FILE^DIE("","RAFDA","") S RAMSG(1)=$C(7)
S RAMSG(2)="You cannot add this procedure to the common procedure list"
S RAMSG(3)="because it is inactivated in the Rad/Nuc Med Procedures file."
S RAMSG(4)="You must first re-activate the procedure through the 'Procedure"
S RAMSG(5)="Enter/Edit' option.",RAMSG(6)="" D MES^XPDUTL(.RAMSG)
Q "@10" ; reset 'Inactive' to 'yes', re-edit field.
;
EN2() ; called from ^DD(74,0,"ID","WRITE")
; display long case #'s in the same print set as current record
N RA1,RA2
S RA1=0,RA2=""
; F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",2)
F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",$L(RA1,"-")) ;P47 to accommodate possible SSAN format
Q RA2
USUAL(RADA,RAX) ; To insure that the USUAL DOSE value falls between the
; HIGH ADULT DOSE and the LOW ADULT DOSE.
; Input Variables:
; RADA -> top level/sub-file level IEN's
; RAX -> value input by the user
; Output Variable: $S(1: value is accepted, 0: value not accepted)
;
Q:RAX="" 0 ; X does not exist
N RA7108,RAH,RAL S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6)
S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL)
I (+RAX<RAL)!(+RAX>RAH) D Q 0 ; value is not accepted
. N RARRY S RARRY(1)="The 'USUAL DOSE' must fall within the range of: "
. S RARRY(1)=RARRY(1)_RAL_" - "_RAH_" "
. D EN^DDIOL(.RARRY)
. Q
E Q 1 ; value accepted
;
RANGE(RADA) ; Determine the range in which the 'USUAL DOSE' must fall
; Input Variables:
; RADA -> top level/sub-file level IEN's
; Output Variable:
; RANGE -> the range in which the 'USUAL DOSE' must fall
N RA7108,RAH,RAL
S RA7108=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
S RAH=$P(RA7108,"^",5),RAL=$P(RA7108,"^",6)
S RAH=$S(RAH="":99999.9999,1:RAH),RAL=$S(RAL="":.0001,1:RAL)
Q RAL_"-"_RAH
MEDOSE(RAY,RADT) ; Determine if this individual (RAY) is authorized to
; administer medications. Called from ^DD(70.15,4,12.1)
; Input : RAY (pnt to 200) - the individual being checked at the moment
; RADT - Date of the examination
; Output: '1' - user is authorized to administer medications, else '0'
;
Q:$D(^VA(200,"ARC","R",RAY)) 1 ; Rad/Nuc Med Class: Resident
Q:$D(^VA(200,"ARC","S",RAY)) 1 ; Rad/Nuc Med Class: Staff
Q:$D(^VA(200,"ARC","T",RAY)) 1 ; Rad/Nuc Med Class: Technologist
Q:$D(^XUSEC("ORES",RAY)) 1 Q:$D(^XUSEC("ORELSE",RAY)) 1
N RAUTH S RAUTH=$G(^VA(200,RAY,"PS"))
; If authorized to write med orders ($P(RAUTH,"^")=1) and inactivation
; date null -OR- inactivation date greater than or equal to the exam
; date individual is authorized.
Q:+$P(RAUTH,"^")&($S('$P(RAUTH,"^",4):1,$P(RAUTH,"^",4)'<RADT:1,1:0)) 1
Q 0
;
PRIDXIXK(DA,X) ;This subroutine executes the KILL logic for the 'new style' AD cross-
;reference on the 'PRIMARY DIAGNOSTIC CODE' (data dictionary: 70.03; field: 13)
;Input: DA - an array where DA(2)=RADFN, DA(1)=RADTI, & DA=RACNI
; X - the primary diagnostic code value (this field points to file 78.3)
N RACNI,RADFN,RADTI,RAFDA,RAIENS,RAX
S RADFN=DA(2),RADTI=DA(1),RACNI=DA,RAX=X ;save the variables just in case
S RAIENS=DA_","_DA(1)_","_DA(2)_",",RAFDA(70.03,RAIENS,20)="@"
D FILE^DIE(,"RAFDA") ;delete data in 'DIAGNOSTIC PRINT DATE' (DD: 70.03; field: 20)
K ^RADPT("AD",RAX,RADFN,RADTI,RACNI)
Q
;
AEASSET(RAX,RADA,RAXREF) ;determine is the examination status of the
;study is either CANCELED or COMPLETE. This routine will set the "AS"
; or "AE" xref SET logic (new style).
;
; Note: The first numeric subscript of the "AE" xref is the
; CASE NUMBER (70.03;.01). Since the .01 field cannot
; be changed because of business rules, the "AE" xref
; does not have set/kill logic in the CASE NUMBER field.
;
; The first numeric subscript of the "AS" xref is the
; EXAMINATION STATUS IEN (70.03;3).
;
;
;input: RAX = value of 'X' passed into from ^DD(70.03,3,0)
; 'X' is the IEN of a record in the EXAMINATION
; STATUS (#72) file.
; RADA = the DA array: DA(2) think RADFN, DA(1) think
; RADTI & DA think RACNI.
; RAXREF = one of two values: "AS" or "AE"
;
;
;ORDER value for CANCELED is zero (0), ORDER value for CANCELED is nine (9)
;ORDER values 0, 1 & 9 are RESERVED. RAIMGTY is set in the input transform
N RAIMGTY,RAY2,RAY3,RAY S RAY=$P($G(^RA(72,RAX,0)),U,3) ;ORDER value
Q:RAY="" S RAY2=$G(^RADPT(RADA(2),"DT",RADA(1),0))
S RAY3=$G(^RADPT(RADA(2),"DT",RADA(1),"P",RADA,0)) ;70.03
S RAIMGTY=$P($G(^RA(79.2,+$P(RAY2,U,2),0)),U) Q:RAIMGTY=""
;^RA(72,"AA","GENERAL RADIOLOGY",1,1)="" 4th subscript is ORDER,
;the 5th is IEN of file 72
Q:'$D(^RA(72,"AA",RAIMGTY,RAY,RAX))#2 ;the "AA" must be preserved
Q:RAY=0!(RAY=9) ;the study is canceled or complete or broken
S:RAXREF="AE"&($P(RAY3,U)>0) ^RADPT("AE",$E(+RAY3,1,30),RADA(2),RADA(1),RADA)=""
S:RAXREF="AS" ^RADPT("AS",$E(RAX,1,30),RADA(2),RADA(1),RADA)=""
Q
;
AEKILL(RADA) ;execute the KILL logic for the "AE" xref on the
;EXAM STATUS field (70.03;3)
;input: RADA = the DA array: DA(2) think RADFN, DA(1) think
; & DA think RACNI.
N RAY3 S RAY3=$G(^RADPT(RADA(2),"DT",RADA(1),"P",RADA,0)) ;70.03
K ^RADPT("AE",$E(+RAY3,1,30),RADA(2),RADA(1),RADA)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADD2 7655 printed Dec 13, 2024@02:34:37 Page 2
RADD2 ;HISC/GJC/CAH-Radiology Data Dictionary Utility Routine ; Feb 11, 2021@11:10:54
+1 ;;5.0;Radiology/Nuclear Medicine;**84,47,124,158,175**;Mar 16, 1998;Build 2
+2 ;
+3 ;Integration Agreements
+4 ;----------------------
+5 ;EN^DDIOL(10142); FILE^DIE(2053);NOTE^ORX3(868);MES^XPDUTL(10141)
+6 ;
EN1(RA71) ; Input transform for the .01 field (Procedure) for the Rad/Nuc
+1 ; Med Common Procedure file i.e, ^RAMIS(71.3 (reworked for RA*5.0*158)
+2 ; Procedure must not have an inactive date before today in file 71
+3 ; Procedure in file 71 must have same imaging type as the one
+4 ; selected before editing this record in file 71.3
+5 ;
+6 ; A PARENT type procedure must have at least one descendent
+7 ; Output:
+8 ; -If at least one descendant return one
+9 ; -else return 0
+10 ;
+11 ; Input:
+12 ; RA71 = IENS of entries in ^RAMIS(71,
+13 ; RAIMGTYI = IEN of an IMAGING TYPE record (global scope)
+14 ;
+15 if '$GET(RAIMGTYI)
QUIT 0
+16 ;
+17 SET RA71("I")=$GET(^RAMIS(71,+RA71,"I"))
SET RA71(0)=$GET(^RAMIS(71,+RA71,0))
+18 ;parent procedure?
+19 SET RAPARENT=$SELECT($PIECE(RA71(0),"^",6)="P":1,1:0)
+20 ;does the parent have a descendant?
+21 if RAPARENT
SET RAPFLG=+$ORDER(^RAMIS(71,+RA71,4,0))
+22 ;
+23 ;if no "I" node or "I" node null ok, if DT is before today ok, else not ok
+24 SET RA71ACTIVE=$SELECT(RA71("I")="":1,DT<RA71("I"):1,1:0)
+25 if RA71ACTIVE=0
QUIT 0
+26 ;
+27 ;match i-type?
+28 SET RA71ITYPE=$SELECT(RAIMGTYI=$PIECE($GET(RA71(0)),"^",12):1,1:0)
+29 if RA71ITYPE=0
QUIT 0
+30 ;
+31 ;if active, w/i-type match & non-parent quit 1
+32 if RAPARENT=0
QUIT 1
+33 ;
+34 ;if active, w/i-type match & parent w/descendant quit 1
+35 if RAPARENT&RAPFLG
QUIT 1
+36 ;
+37 KILL RA71ACTIVE,RA71ITYPE,RAPARENT,RAPFLG
+38 QUIT 0
+39 ;
CH ;this tag was removed w/RA*5.0*175
+1 QUIT
+2 ;
INACOM(RAD0) ; Check inactive date on the Rad/Nuc Med Procedure file (71)
+1 ; for the Common Procedure before setting our inactive procedure to
+2 ; active. Called from the 'RA COMMON PROCEDURE EDIT' input template.
+3 ; Option: Common Procedure Enter/Edit (13^RAMAIN2)
+4 ; Input : RAD0-ien of Rad/Nuc Med Common Procedure
+5 ; Output: if Common cannot be re-activated, reset the 'Inactive' field
+6 ; to 'yes'.
+7 NEW RAINA
SET RAINA=$PIECE($GET(^RAMIS(71,+$PIECE($GET(^RAMIS(71.3,RAD0,0)),"^"),"I")),"^")
+8 ; we can inactivate the common
if RAINA=""!(RAINA>DT)
QUIT "@15"
+9 NEW RAFDA,RAMSG
+10 SET RAFDA(71.3,RAD0_",",4)="Y"
DO FILE^DIE("","RAFDA","")
SET RAMSG(1)=$CHAR(7)
+11 SET RAMSG(2)="You cannot add this procedure to the common procedure list"
+12 SET RAMSG(3)="because it is inactivated in the Rad/Nuc Med Procedures file."
+13 SET RAMSG(4)="You must first re-activate the procedure through the 'Procedure"
+14 SET RAMSG(5)="Enter/Edit' option."
SET RAMSG(6)=""
DO MES^XPDUTL(.RAMSG)
+15 ; reset 'Inactive' to 'yes', re-edit field.
QUIT "@10"
+16 ;
EN2() ; called from ^DD(74,0,"ID","WRITE")
+1 ; display long case #'s in the same print set as current record
+2 NEW RA1,RA2
+3 SET RA1=0
SET RA2=""
+4 ; F S RA1=$O(^RARPT(Y,1,"B",RA1)) Q:'RA1 S RA2=RA2_$S(RA2="":"-",1:",-")_$P(RA1,"-",2)
+5 ;P47 to accommodate possible SSAN format
FOR
SET RA1=$ORDER(^RARPT(Y,1,"B",RA1))
if 'RA1
QUIT
SET RA2=RA2_$SELECT(RA2="":"-",1:",-")_$PIECE(RA1,"-",$LENGTH(RA1,"-"))
+6 QUIT RA2
USUAL(RADA,RAX) ; To insure that the USUAL DOSE value falls between the
+1 ; HIGH ADULT DOSE and the LOW ADULT DOSE.
+2 ; Input Variables:
+3 ; RADA -> top level/sub-file level IEN's
+4 ; RAX -> value input by the user
+5 ; Output Variable: $S(1: value is accepted, 0: value not accepted)
+6 ;
+7 ; X does not exist
if RAX=""
QUIT 0
+8 NEW RA7108,RAH,RAL
SET RA7108=$GET(^RAMIS(71,RADA(1),"NUC",RADA,0))
+9 SET RAH=$PIECE(RA7108,"^",5)
SET RAL=$PIECE(RA7108,"^",6)
+10 SET RAH=$SELECT(RAH="":99999.9999,1:RAH)
SET RAL=$SELECT(RAL="":.0001,1:RAL)
+11 ; value is not accepted
IF (+RAX<RAL)!(+RAX>RAH)
Begin DoDot:1
+12 NEW RARRY
SET RARRY(1)="The 'USUAL DOSE' must fall within the range of: "
+13 SET RARRY(1)=RARRY(1)_RAL_" - "_RAH_" "
+14 DO EN^DDIOL(.RARRY)
+15 QUIT
End DoDot:1
QUIT 0
+16 ; value accepted
IF '$TEST
QUIT 1
+17 ;
RANGE(RADA) ; Determine the range in which the 'USUAL DOSE' must fall
+1 ; Input Variables:
+2 ; RADA -> top level/sub-file level IEN's
+3 ; Output Variable:
+4 ; RANGE -> the range in which the 'USUAL DOSE' must fall
+5 NEW RA7108,RAH,RAL
+6 SET RA7108=$GET(^RAMIS(71,RADA(1),"NUC",RADA,0))
+7 SET RAH=$PIECE(RA7108,"^",5)
SET RAL=$PIECE(RA7108,"^",6)
+8 SET RAH=$SELECT(RAH="":99999.9999,1:RAH)
SET RAL=$SELECT(RAL="":.0001,1:RAL)
+9 QUIT RAL_"-"_RAH
MEDOSE(RAY,RADT) ; Determine if this individual (RAY) is authorized to
+1 ; administer medications. Called from ^DD(70.15,4,12.1)
+2 ; Input : RAY (pnt to 200) - the individual being checked at the moment
+3 ; RADT - Date of the examination
+4 ; Output: '1' - user is authorized to administer medications, else '0'
+5 ;
+6 ; Rad/Nuc Med Class: Resident
if $DATA(^VA(200,"ARC","R",RAY))
QUIT 1
+7 ; Rad/Nuc Med Class: Staff
if $DATA(^VA(200,"ARC","S",RAY))
QUIT 1
+8 ; Rad/Nuc Med Class: Technologist
if $DATA(^VA(200,"ARC","T",RAY))
QUIT 1
+9 if $DATA(^XUSEC("ORES",RAY))
QUIT 1
if $DATA(^XUSEC("ORELSE",RAY))
QUIT 1
+10 NEW RAUTH
SET RAUTH=$GET(^VA(200,RAY,"PS"))
+11 ; If authorized to write med orders ($P(RAUTH,"^")=1) and inactivation
+12 ; date null -OR- inactivation date greater than or equal to the exam
+13 ; date individual is authorized.
+14 if +$PIECE(RAUTH,"^")&($SELECT('$PIECE(RAUTH,"^",4)
QUIT 1
+15 QUIT 0
+16 ;
PRIDXIXK(DA,X) ;This subroutine executes the KILL logic for the 'new style' AD cross-
+1 ;reference on the 'PRIMARY DIAGNOSTIC CODE' (data dictionary: 70.03; field: 13)
+2 ;Input: DA - an array where DA(2)=RADFN, DA(1)=RADTI, & DA=RACNI
+3 ; X - the primary diagnostic code value (this field points to file 78.3)
+4 NEW RACNI,RADFN,RADTI,RAFDA,RAIENS,RAX
+5 ;save the variables just in case
SET RADFN=DA(2)
SET RADTI=DA(1)
SET RACNI=DA
SET RAX=X
+6 SET RAIENS=DA_","_DA(1)_","_DA(2)_","
SET RAFDA(70.03,RAIENS,20)="@"
+7 ;delete data in 'DIAGNOSTIC PRINT DATE' (DD: 70.03; field: 20)
DO FILE^DIE(,"RAFDA")
+8 KILL ^RADPT("AD",RAX,RADFN,RADTI,RACNI)
+9 QUIT
+10 ;
AEASSET(RAX,RADA,RAXREF) ;determine is the examination status of the
+1 ;study is either CANCELED or COMPLETE. This routine will set the "AS"
+2 ; or "AE" xref SET logic (new style).
+3 ;
+4 ; Note: The first numeric subscript of the "AE" xref is the
+5 ; CASE NUMBER (70.03;.01). Since the .01 field cannot
+6 ; be changed because of business rules, the "AE" xref
+7 ; does not have set/kill logic in the CASE NUMBER field.
+8 ;
+9 ; The first numeric subscript of the "AS" xref is the
+10 ; EXAMINATION STATUS IEN (70.03;3).
+11 ;
+12 ;
+13 ;input: RAX = value of 'X' passed into from ^DD(70.03,3,0)
+14 ; 'X' is the IEN of a record in the EXAMINATION
+15 ; STATUS (#72) file.
+16 ; RADA = the DA array: DA(2) think RADFN, DA(1) think
+17 ; RADTI & DA think RACNI.
+18 ; RAXREF = one of two values: "AS" or "AE"
+19 ;
+20 ;
+21 ;ORDER value for CANCELED is zero (0), ORDER value for CANCELED is nine (9)
+22 ;ORDER values 0, 1 & 9 are RESERVED. RAIMGTY is set in the input transform
+23 ;ORDER value
NEW RAIMGTY,RAY2,RAY3,RAY
SET RAY=$PIECE($GET(^RA(72,RAX,0)),U,3)
+24 if RAY=""
QUIT
SET RAY2=$GET(^RADPT(RADA(2),"DT",RADA(1),0))
+25 ;70.03
SET RAY3=$GET(^RADPT(RADA(2),"DT",RADA(1),"P",RADA,0))
+26 SET RAIMGTY=$PIECE($GET(^RA(79.2,+$PIECE(RAY2,U,2),0)),U)
if RAIMGTY=""
QUIT
+27 ;^RA(72,"AA","GENERAL RADIOLOGY",1,1)="" 4th subscript is ORDER,
+28 ;the 5th is IEN of file 72
+29 ;the "AA" must be preserved
if '$DATA(^RA(72,"AA",RAIMGTY,RAY,RAX))#2
QUIT
+30 ;the study is canceled or complete or broken
if RAY=0!(RAY=9)
QUIT
+31 if RAXREF="AE"&($PIECE(RAY3,U)>0)
SET ^RADPT("AE",$EXTRACT(+RAY3,1,30),RADA(2),RADA(1),RADA)=""
+32 if RAXREF="AS"
SET ^RADPT("AS",$EXTRACT(RAX,1,30),RADA(2),RADA(1),RADA)=""
+33 QUIT
+34 ;
AEKILL(RADA) ;execute the KILL logic for the "AE" xref on the
+1 ;EXAM STATUS field (70.03;3)
+2 ;input: RADA = the DA array: DA(2) think RADFN, DA(1) think
+3 ; & DA think RACNI.
+4 ;70.03
NEW RAY3
SET RAY3=$GET(^RADPT(RADA(2),"DT",RADA(1),"P",RADA,0))
+5 KILL ^RADPT("AE",$EXTRACT(+RAY3,1,30),RADA(2),RADA(1),RADA)
+6 QUIT
+7 ;
