RADD3 ;HISC/SWM-Radiology Data Dictionary Utility Routine ; Oct 12, 2022@10:55:50
;;5.0;Radiology/Nuclear Medicine;**18,65,154,194**;Mar 16, 1998;Build 1
;
;Supported IA #2056 reference to GET1^DIQ
;Supported IA #10142 reference to EN^DDIOL
;Supported IA #2053 reference to UPDATE^DIE, FILE^DIE
;Supported IA #10103 reference to NOW^XLFDT
;
PAIR ;
; called from file 71.9's field SOURCE
; SOURCE may be added normally via the "RA NM EDIT LOT" option,
; or it may be added via one of the 3 exam edits when the LOT
; prompt appears for the case's Radiopharm. This LOT prompt
; allows adding new LOT on-the-fly, which causes the LOT's
; associated SOURCE, EXPIRATION DATE, KIT # to be prompted
; and the current case's Radiopharm to be stuffed into the new LOT's
; Radiopharm field. The SOURCE field invokes this subroutine to:
; re-set DR string to stuff matching radiopharm
; not allow spacebar return for radioph
; RA*5*65 removed the Fileman Identifier for file 79.1's RADIOPHARM
; so by default, the DR will just be "2;3;4;" without the "5;".
;
N RA1,RA2,RA3
I $D(RAOPT("EDITPT"))!($D(RAOPT("EDITCN")))!($D(RAOPT("STATRACK"))) D
. S RA1=$$EN1^RAPSAPI(RAPSDRUG,.01)
. I $G(DR)'[";5",$G(DIE)="^RAMIS(71.9,",+$G(RAPSDRUG),RA1]"" S DR=DR_"5///"_RA1 K ^DISV(DUZ,"^RAMIS(71.9,")
. Q
; check pairing of number/id with source
; called by input transform of file 71.9'S field 2 (source)
S (RA1,RA2,RA3)=""
Q:$G(DA)="" Q:$G(D)=""
F S RA1=$O(^RAMIS(71.9,"B",$P(D,U),RA1)) Q:'RA1 I DA'=RA1 S:$P(^RAMIS(71.9,RA1,0),U,2)=+Y RA2=1 ;found a match so set ra2=1
W:RA2 !!,"** There's already a NUMBER/ID=",$P(D,U)," and SOURCE=",$P(Y,U,2)," **",!
K:RA2 X
Q
SCRLOT() ;screen lot # from file 70.2
;lot's exp. dt must be within d/t dose admin, if no admin, use exam dt
; if lot's exp. dt is null, allow as choice (don't check)
;lot's radiopharm must match exam's radiopharm
; if lot's radiopharm is null, don't allow as choice
;Y pointer to lot file
;RA0A date/time dose administered
;RA0E date/time exam
;RALOTEXP lot's expiration date
;RA0RAD exam's radiopharmaceutical
;RALOTRAD lot's radiopharmaceutical
;RARETUR return value of screen, 0=failed, 1=passed
I '$D(Y)#2!('$D(DA))!('$D(DA(1))) Q 0
N RA0A,RA0E,RALOTEXP,RA0RAD,RALOTRAD,RARETURN
S RARETURN=0
S RA0E=$P(^RADPTN(DA(1),0),U,2),RA0A=$P(^("NUC",DA,0),U,8),RA0RAD=$P(^(0),U),RALOTEXP=$P(^RAMIS(71.9,+Y,0),U,3),RALOTRAD=$P(^(0),U,5)
I $S(RALOTEXP="":1,RA0A:RALOTEXP>RA0A,1:RALOTEXP>RA0E),(RA0RAD=RALOTRAD) S RARETURN=1
Q RARETURN
;
GETID(Y) ; Pass back a string of data which will be used as an
; identifier when lookups are done on the Imaging Locations (79.1) file
; Input : Y -> ien of entry in 79.1
; Output: string of data relevent to the entry in file 79.1
; Location I-type_"-"_Station # of Rad/Nuc Med Division
; *Location I-type_"-"_Station # of Rad/Nuc Med Division
; Note: The asterisk preceeding the Location I-type name
; indicates the I-loc is inactive. (P194)
;
N RA791,RASTR
S RA791(0)=$G(^RA(79.1,Y,0)),RA791("DIV")=$G(^RA(79.1,Y,"DIV"))
S RA791(19)=$S($P(RA791(0),"^",19)]"":"*",1:"") ;no future D/T allowed
S RA791(6)=$$GET1^DIQ(79.2,+$P(RA791(0),"^",6),.01)
S RA791(25)=$$GET1^DIQ(4,+$P(RA791("DIV"),"^"),99)
S RASTR="("_RA791(19)_RA791(6)_"-"_RA791(25)_")"
Q RASTR
;
DELDESC(RAIEN) ; This sub-routine will determine if descendents can be
; deleted from parent procedures. If only one descendent exists, and
; the parent is on the common procedure list do not allow the deletion
; of the descendent.
; Input : RAIEN (the DA array for the Rad/Nuc Med Procedure file.)
; Output: 0 if ok to delete, 1 if not ok to delete
; Called from: ^DD(71.05,.01,"DEL",1,0) node
N I,RA713,RATTL S (I,RA713,RATTL)=0
S:$D(^RAMIS(71.3,"B",RAIEN(1))) RA713=+$O(^RAMIS(71.3,"B",RAIEN(1),0))
S:RA713>0 RA713(0)=$G(^RAMIS(71.3,RA713,0))
F S I=$O(^RAMIS(71,RAIEN(1),4,I)) Q:I'>0 S RATTL=RATTL+1
I RA713,($P(RA713(0),"^",5)=""),(RATTL=1) D Q 1
. ; don't allow deletion of the last descendent on procedures that are
. ; currently active in the common procedure file.
. N RATXT S RATXT(1)=" "
. S RATXT(2)="You cannot delete the last or only descendent from a"
. S RATXT(3)="parent procedure when the parent procedure is an active"
. S RATXT(4)="common procedure.",RATXT(5)=$C(7) D EN^DDIOL(.RATXT)
. Q
Q 0 ; common procedure with more than one descendent, ok to delete
;
REACMMN(RADA) ; Check to see if a commom procedure can be re-activated.
; This sub-routine checks if this common is a parent w/o descendents.
; If true, this common procedure cannot be re-activated.
; Input : RADA - ien of the entry in 71.3
; Output: 0 if ok to delete, 1 if not ok to delete
; Called from ^DD(71.3,4,"DEL",1,0)
N RA713 S RA713=$G(^RAMIS(71.3,RADA,0))
I $P($G(^RAMIS(71,+RA713,0)),"^",6)="P",('$O(^RAMIS(71,+RA713,4,0))) D Q 1
. N RATXT S RATXT(1)=" "
. S RATXT(2)="You cannot re-activate a common parent procedure without descendents."
. S RATXT(3)=$C(7) D EN^DDIOL(.RATXT)
. Q
Q 0 ; ok to delete
;
X7005(RADFN,RADTI,RACNI,RAMDV,RAQED,RASTI,RAWHO) ;update the EXAM
; STATUS TIMES (70.05) multiple. Called from RASTED (will be
; called from RAUTL1 in the future)
;
; input variables:
; ----------------
; RADFN=patient dfn, RADTI=exam date/time (inverse)
; RACNI=exam record ien (70.03), RAMDV=division parameters
; RAQED=task queued(1=yes;0=no), RASTI=exam status
; RAWHO=editing person
;
N %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,X,Y
S RAQED=+$G(RAQED) ; if tasked 1, else 0
S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_","
S RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT())
D UPDATE^DIE(,"RAFDA","RAIEN") ; RAIEN(1)=ien of new record
K RAFDA,RAIENS Q:'$D(RAIEN(1)) ; record not added
I $P(RAMDV,"^",11),('RAQED) D
.S DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","_RACNI_",""T"","
.S DA=RAIEN(1),DR=".01" D ^DIE
S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_","
S RAFDA(70.05,RAIENS,2)=RASTI
S RAFDA(70.05,RAIENS,3)=$G(RAWHO)
D FILE^DIE(,"RAFDA")
Q
A7007(RADFN,RADTI,RACNI,RAWHO,RATC) ; update the ACTIVITY LOG (70.07)
; multiple. Called from RASTED (will be called from RAUTL1 in the
; future)
;
; input variables:
; ----------------
; RADFN=patient dfn, RADTI=exam date/time (inverse)
; RACNI=exam record ien (70.03), RAWHO=editing person
; RATC=technologist comments (optional)
;
N %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,RATOA,X,Y
S RATOA=$S($D(RAOPT("STATRACK")):"S",1:"U") ;p154 Reflect option used
S RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_","
S RAFDA(70.07,RAIENS,.01)="NOW"
D UPDATE^DIE("E","RAFDA","RAIEN") ;RAIEN(1)=ien of new record
K RAFDA,RAIENS Q:'$D(RAIEN(1)) ; record not added
S RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_","
S RAFDA(70.07,RAIENS,2)=RATOA
S RAFDA(70.07,RAIENS,3)=$G(RAWHO)
S:$G(RATC)]"" RAFDA(70.07,RAIENS,4)=RATC
D FILE^DIE(,"RAFDA")
Q
;
;updates EXAM STATUS
U70033(RA18DFN,RA18DTI,RA18CNI,RA18ST) ;
N %,D,D0,DA,DIC,DIE,DQ,DR,RA18FDA,RA18IENS,X,Y
S RA18IENS=RA18CNI_","_RA18DTI_","_RA18DFN_","
S RA18FDA(70.03,RA18IENS,3)=RA18ST
D FILE^DIE(,"RA18FDA")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRADD3 7330 printed Apr 09, 2024@21:39:51 Page 2
RADD3 ;HISC/SWM-Radiology Data Dictionary Utility Routine ; Oct 12, 2022@10:55:50
+1 ;;5.0;Radiology/Nuclear Medicine;**18,65,154,194**;Mar 16, 1998;Build 1
+2 ;
+3 ;Supported IA #2056 reference to GET1^DIQ
+4 ;Supported IA #10142 reference to EN^DDIOL
+5 ;Supported IA #2053 reference to UPDATE^DIE, FILE^DIE
+6 ;Supported IA #10103 reference to NOW^XLFDT
+7 ;
PAIR ;
+1 ; called from file 71.9's field SOURCE
+2 ; SOURCE may be added normally via the "RA NM EDIT LOT" option,
+3 ; or it may be added via one of the 3 exam edits when the LOT
+4 ; prompt appears for the case's Radiopharm. This LOT prompt
+5 ; allows adding new LOT on-the-fly, which causes the LOT's
+6 ; associated SOURCE, EXPIRATION DATE, KIT # to be prompted
+7 ; and the current case's Radiopharm to be stuffed into the new LOT's
+8 ; Radiopharm field. The SOURCE field invokes this subroutine to:
+9 ; re-set DR string to stuff matching radiopharm
+10 ; not allow spacebar return for radioph
+11 ; RA*5*65 removed the Fileman Identifier for file 79.1's RADIOPHARM
+12 ; so by default, the DR will just be "2;3;4;" without the "5;".
+13 ;
+14 NEW RA1,RA2,RA3
+15 IF $DATA(RAOPT("EDITPT"))!($DATA(RAOPT("EDITCN")))!($DATA(RAOPT("STATRACK")))
Begin DoDot:1
+16 SET RA1=$$EN1^RAPSAPI(RAPSDRUG,.01)
+17 IF $GET(DR)'[";5"
IF $GET(DIE)="^RAMIS(71.9,"
IF +$GET(RAPSDRUG)
IF RA1]""
SET DR=DR_"5///"_RA1
KILL ^DISV(DUZ,"^RAMIS(71.9,")
+18 QUIT
End DoDot:1
+19 ; check pairing of number/id with source
+20 ; called by input transform of file 71.9'S field 2 (source)
+21 SET (RA1,RA2,RA3)=""
+22 if $GET(DA)=""
QUIT
if $GET(D)=""
QUIT
+23 ;found a match so set ra2=1
FOR
SET RA1=$ORDER(^RAMIS(71.9,"B",$PIECE(D,U),RA1))
if 'RA1
QUIT
IF DA'=RA1
if $PIECE(^RAMIS(71.9,RA1,0),U,2)=+Y
SET RA2=1
+24 if RA2
WRITE !!,"** There's already a NUMBER/ID=",$PIECE(D,U)," and SOURCE=",$PIECE(Y,U,2)," **",!
+25 if RA2
KILL X
+26 QUIT
SCRLOT() ;screen lot # from file 70.2
+1 ;lot's exp. dt must be within d/t dose admin, if no admin, use exam dt
+2 ; if lot's exp. dt is null, allow as choice (don't check)
+3 ;lot's radiopharm must match exam's radiopharm
+4 ; if lot's radiopharm is null, don't allow as choice
+5 ;Y pointer to lot file
+6 ;RA0A date/time dose administered
+7 ;RA0E date/time exam
+8 ;RALOTEXP lot's expiration date
+9 ;RA0RAD exam's radiopharmaceutical
+10 ;RALOTRAD lot's radiopharmaceutical
+11 ;RARETUR return value of screen, 0=failed, 1=passed
+12 IF '$DATA(Y)#2!('$DATA(DA))!('$DATA(DA(1)))
QUIT 0
+13 NEW RA0A,RA0E,RALOTEXP,RA0RAD,RALOTRAD,RARETURN
+14 SET RARETURN=0
+15 SET RA0E=$PIECE(^RADPTN(DA(1),0),U,2)
SET RA0A=$PIECE(^("NUC",DA,0),U,8)
SET RA0RAD=$PIECE(^(0),U)
SET RALOTEXP=$PIECE(^RAMIS(71.9,+Y,0),U,3)
SET RALOTRAD=$PIECE(^(0),U,5)
+16 IF $SELECT(RALOTEXP="":1,RA0A:RALOTEXP>RA0A,1:RALOTEXP>RA0E)
IF (RA0RAD=RALOTRAD)
SET RARETURN=1
+17 QUIT RARETURN
+18 ;
GETID(Y) ; Pass back a string of data which will be used as an
+1 ; identifier when lookups are done on the Imaging Locations (79.1) file
+2 ; Input : Y -> ien of entry in 79.1
+3 ; Output: string of data relevent to the entry in file 79.1
+4 ; Location I-type_"-"_Station # of Rad/Nuc Med Division
+5 ; *Location I-type_"-"_Station # of Rad/Nuc Med Division
+6 ; Note: The asterisk preceeding the Location I-type name
+7 ; indicates the I-loc is inactive. (P194)
+8 ;
+9 NEW RA791,RASTR
+10 SET RA791(0)=$GET(^RA(79.1,Y,0))
SET RA791("DIV")=$GET(^RA(79.1,Y,"DIV"))
+11 ;no future D/T allowed
SET RA791(19)=$SELECT($PIECE(RA791(0),"^",19)]"":"*",1:"")
+12 SET RA791(6)=$$GET1^DIQ(79.2,+$PIECE(RA791(0),"^",6),.01)
+13 SET RA791(25)=$$GET1^DIQ(4,+$PIECE(RA791("DIV"),"^"),99)
+14 SET RASTR="("_RA791(19)_RA791(6)_"-"_RA791(25)_")"
+15 QUIT RASTR
+16 ;
DELDESC(RAIEN) ; This sub-routine will determine if descendents can be
+1 ; deleted from parent procedures. If only one descendent exists, and
+2 ; the parent is on the common procedure list do not allow the deletion
+3 ; of the descendent.
+4 ; Input : RAIEN (the DA array for the Rad/Nuc Med Procedure file.)
+5 ; Output: 0 if ok to delete, 1 if not ok to delete
+6 ; Called from: ^DD(71.05,.01,"DEL",1,0) node
+7 NEW I,RA713,RATTL
SET (I,RA713,RATTL)=0
+8 if $DATA(^RAMIS(71.3,"B",RAIEN(1)))
SET RA713=+$ORDER(^RAMIS(71.3,"B",RAIEN(1),0))
+9 if RA713>0
SET RA713(0)=$GET(^RAMIS(71.3,RA713,0))
+10 FOR
SET I=$ORDER(^RAMIS(71,RAIEN(1),4,I))
if I'>0
QUIT
SET RATTL=RATTL+1
+11 IF RA713
IF ($PIECE(RA713(0),"^",5)="")
IF (RATTL=1)
Begin DoDot:1
+12 ; don't allow deletion of the last descendent on procedures that are
+13 ; currently active in the common procedure file.
+14 NEW RATXT
SET RATXT(1)=" "
+15 SET RATXT(2)="You cannot delete the last or only descendent from a"
+16 SET RATXT(3)="parent procedure when the parent procedure is an active"
+17 SET RATXT(4)="common procedure."
SET RATXT(5)=$CHAR(7)
DO EN^DDIOL(.RATXT)
+18 QUIT
End DoDot:1
QUIT 1
+19 ; common procedure with more than one descendent, ok to delete
QUIT 0
+20 ;
REACMMN(RADA) ; Check to see if a commom procedure can be re-activated.
+1 ; This sub-routine checks if this common is a parent w/o descendents.
+2 ; If true, this common procedure cannot be re-activated.
+3 ; Input : RADA - ien of the entry in 71.3
+4 ; Output: 0 if ok to delete, 1 if not ok to delete
+5 ; Called from ^DD(71.3,4,"DEL",1,0)
+6 NEW RA713
SET RA713=$GET(^RAMIS(71.3,RADA,0))
+7 IF $PIECE($GET(^RAMIS(71,+RA713,0)),"^",6)="P"
IF ('$ORDER(^RAMIS(71,+RA713,4,0)))
Begin DoDot:1
+8 NEW RATXT
SET RATXT(1)=" "
+9 SET RATXT(2)="You cannot re-activate a common parent procedure without descendents."
+10 SET RATXT(3)=$CHAR(7)
DO EN^DDIOL(.RATXT)
+11 QUIT
End DoDot:1
QUIT 1
+12 ; ok to delete
QUIT 0
+13 ;
X7005(RADFN,RADTI,RACNI,RAMDV,RAQED,RASTI,RAWHO) ;update the EXAM
+1 ; STATUS TIMES (70.05) multiple. Called from RASTED (will be
+2 ; called from RAUTL1 in the future)
+3 ;
+4 ; input variables:
+5 ; ----------------
+6 ; RADFN=patient dfn, RADTI=exam date/time (inverse)
+7 ; RACNI=exam record ien (70.03), RAMDV=division parameters
+8 ; RAQED=task queued(1=yes;0=no), RASTI=exam status
+9 ; RAWHO=editing person
+10 ;
+11 NEW %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,X,Y
+12 ; if tasked 1, else 0
SET RAQED=+$GET(RAQED)
+13 SET RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_","
+14 SET RAFDA(70.05,RAIENS,.01)=$$MIDNGHT^RAUTL5($$NOW^XLFDT())
+15 ; RAIEN(1)=ien of new record
DO UPDATE^DIE(,"RAFDA","RAIEN")
+16 ; record not added
KILL RAFDA,RAIENS
if '$DATA(RAIEN(1))
QUIT
+17 IF $PIECE(RAMDV,"^",11)
IF ('RAQED)
Begin DoDot:1
+18 SET DIE="^RADPT("_RADFN_",""DT"","_RADTI_",""P"","_RACNI_",""T"","
+19 SET DA=RAIEN(1)
SET DR=".01"
DO ^DIE
End DoDot:1
+20 SET RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_","
+21 SET RAFDA(70.05,RAIENS,2)=RASTI
+22 SET RAFDA(70.05,RAIENS,3)=$GET(RAWHO)
+23 DO FILE^DIE(,"RAFDA")
+24 QUIT
A7007(RADFN,RADTI,RACNI,RAWHO,RATC) ; update the ACTIVITY LOG (70.07)
+1 ; multiple. Called from RASTED (will be called from RAUTL1 in the
+2 ; future)
+3 ;
+4 ; input variables:
+5 ; ----------------
+6 ; RADFN=patient dfn, RADTI=exam date/time (inverse)
+7 ; RACNI=exam record ien (70.03), RAWHO=editing person
+8 ; RATC=technologist comments (optional)
+9 ;
+10 NEW %,D,D0,DA,DIC,DIE,DQ,DR,RAFDA,RAIEN,RAIENS,RATOA,X,Y
+11 ;p154 Reflect option used
SET RATOA=$SELECT($DATA(RAOPT("STATRACK")):"S",1:"U")
+12 SET RAIENS="+1,"_RACNI_","_RADTI_","_RADFN_","
+13 SET RAFDA(70.07,RAIENS,.01)="NOW"
+14 ;RAIEN(1)=ien of new record
DO UPDATE^DIE("E","RAFDA","RAIEN")
+15 ; record not added
KILL RAFDA,RAIENS
if '$DATA(RAIEN(1))
QUIT
+16 SET RAIENS=RAIEN(1)_","_RACNI_","_RADTI_","_RADFN_","
+17 SET RAFDA(70.07,RAIENS,2)=RATOA
+18 SET RAFDA(70.07,RAIENS,3)=$GET(RAWHO)
+19 if $GET(RATC)]""
SET RAFDA(70.07,RAIENS,4)=RATC
+20 DO FILE^DIE(,"RAFDA")
+21 QUIT
+22 ;
+23 ;updates EXAM STATUS
U70033(RA18DFN,RA18DTI,RA18CNI,RA18ST) ;
+1 NEW %,D,D0,DA,DIC,DIE,DQ,DR,RA18FDA,RA18IENS,X,Y
+2 SET RA18IENS=RA18CNI_","_RA18DTI_","_RA18DFN_","
+3 SET RA18FDA(70.03,RA18IENS,3)=RA18ST
+4 DO FILE^DIE(,"RA18FDA")
+5 QUIT
+6 ;
