RAUTL15 ;HISC/GJC-Skeleton rpt del if no data entered. ;13 Apr 2018 3:37 PM
;;5.0;Radiology/Nuclear Medicine;**5,10,47,144**;Mar 16, 1998;Build 1
EN3(IEN74) ;Delete the skeleton report and pointer from Rad Pt file to
; report if user has not entered any report data (i.e. user ^'d out
; of report entry/edit after the system created a skeleton record).
; If the report is deleted, a bulletin will not be generated!
N RA,RAPRG74,RATXT
S RA(0)=$G(^RARPT(IEN74,0)) Q:RA(0)']"" 0
I $O(^RARPT(IEN74,2005,0))>0 Q 0
S RA("I")=$S(+$O(^RARPT(IEN74,"I",0))'>0:1,1:0)
S RA("P")=$S($G(^RARPT(IEN74,"P"))="":1,1:0)
S RA("R")=$S(+$O(^RARPT(IEN74,"R",0))'>0:1,1:0)
S RA(5)=$P(RA(0),"^",5),RA(5)=$S(RA(5)]"":RA(5),1:"Null")
I $L(RA(0),"^")'>6,("dD"[RA(5)),(RA("I")),(RA("P")),(RA("R")) D Q 1
. N %,D,D0,DA,DIC,DIE,DIK,DQ,DR,X,Y
. ; +++++ Delete Report Text pointer from the Examinations +++++
. ; +++++ multiple in the Rad/Nuc Med Patient file +++++
. ; +++++ if the data is xrefed, delete xref +++++
. ; del other print member's REPORT TEXT xrefs, & set ptr to #74 as null
. D DEL17^RARTE2(IEN74)
. ; set RADFN, RADTI & RACNI if not defined! This situation will arise
. ; when this code finds an incomplete Rad/Nuc Med Report while running
. ; the post-init portion of the software.
. S:'$D(RADFN) RADFN=$P(RA(0),"^",2)
. S:'$D(RADTI) RADTI=9999999.9999-$P(RA(0),"^",3)
. S:'$D(RACNI) RACNI=+$O(^RADPT(RADFN,"DT",RADTI,"P","B",+$P(RA(0),"^",4),0))
. S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
. D ENKILL^RAXREF(70.03,17,IEN74,.DA)
. ; Delete pointers to the Rad/Nuc Med Report file i.e, '^RARPT('
. ;*******
. S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)="" K DA,X
. ; +++++ Delete Report pntr from the Reports multiple in +++++
. ; +++++ the Reports Batches file +++++
. ; +++++ Delete Report pntr from the Report Distribution file +++++
. D UPDTPNT^RAUTL9(IEN74)
. ; +++++ Delete the entry from the Rad/Nuc Med Reports file +++++
. S DA=IEN74,DIK="^RARPT(" D ^DIK
. S RATXT(1)=" "
. S RATXT(2)=" Report not complete. Must Delete......deletion complete!"
. S RATXT(3)=$C(7) D MES^XPDUTL(.RATXT)
. Q
Q 0
KMV ; kill miscellaneous variables
K %DT,%I,%RET,%T
K D,D0,D1,D2,D3,DA,DDER,DDH,DI,DIE,DIFLD,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DG,DK,DL,DM,DN,DR
K POP
Q
;
CZECH(Y) ; check if an order can be cancelled, held, or scheduled.
; Y -> ien of the Rad/Nuc Med Orders file.
; Y1 -> if OE/RR > 2.5 & no order number: 1, else 0
; Called from: VALORD subroutine
N RAORDER,Y1 S Y1=0
S RAORDER(0)=$G(^RAO(75.1,+Y,0)) Q:RAORDER(0)']""
I '$P(RAORDER(0),U,7),(+$$ORVR^RAORDU()>2.5) D
. N Y2 ; 'Y2' is the procedure name
. S Y1=1,Y2=$P($G(^RAMIS(71,+$P(RAORDER(0),U,2),0)),U)
. D INV(RAOPTN,Y2)
. Q
Q Y1
INV(X,X1) ; invalid action message called from the schedule/cancel or hold
; request options.
; X -> point of orgin (option) X1 -> procedure name
; Called from: CZECH subroutine
S X=$$UP^XLFSTR($E(X,1,3)),X1=$S(X1]"":X1,1:"Unknown")
W !!?3,"Sorry, can't "_$S(X="SCH":"schedule",X="CAN":"cancel",1:"hold")
W " this request until OE/RR assigns an order number"
W !?3,"for procedure: ",X1,!?3,"Please try later!"
Q
VALORD ; validate order data, i.e, has OE/RR order # and the site is running
; a version of OE/RR > 2.5 Called from: 2^RAORD, 3^RAORD & 4^RAORD
N G1,G2,RA751 S G1=0
F S G1=$O(RAORDS(G1)) Q:G1'>0 D
. S G2=$$CZECH(+$G(RAORDS(G1))) K:G2 RAORDS(G1)
. Q
Q
DPROC(RADFN,RADTI,RACNI,RAOIFN) ; Determine if the ordered procedure is
; different from the registered procedure.
; Input Variables: RADFN-Patient DFN
; RADTI-inverse DT of exam (if exists)
; RACNI-IEN on the case node (if exists)
; RAOIFN-IEN of the order
; Output: null-procedures don't differ -OR- no order/exam
; not null-ordered proc_"^"_registered proc data
; registered procedure data includes imaging type, procedure
; type and CPT codes (if any)
;
; NOTE: The only time we don't set ^TMP($J,"RA DIFF PRC") is when
; we are using the 'Detailed Request Display' option and the ordered
; procedure is the same as the registered procedure. All other
; Request display options output the ordered procedure, the
; registered procedure and exam case number if the order
; is active.
;
N RA7003,RA751
S RA7003=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
S RA751=$G(^RAO(75.1,RAOIFN,0))
Q:$P(RA7003,"^",2)=""!($P(RA751,"^",2)="") "" ; missing order or xam
;KLM/P144 - removed condition for procedure change. Save it off no matter what
N RA71,RACPT,RACSE,RAITY,RAPRC,RATY,X,Y
S RACSE=$$RJ^XLFSTR($P(RA7003,"^"),5)
N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACSE)
S RA71=$G(^RAMIS(71,$P(RA7003,"^",2),0))
S RACPT=$P($$NAMCODE^RACPTMSC(+$P(RA71,"^",9),DT),"^")
S RAPRC=$E($$GET1^DIQ(71,+$P(RA7003,"^",2)_",",.01),1,36)
S RAITY=$$GET1^DIQ(79.2,+$P(RA71,"^",12)_",",3)
S RATY=$$GET1^DIQ(71,$P(RA7003,"^",2)_",",6)
S RATY=$E(RATY,1)_$$LOW^XLFSTR($E(RATY,2,9999))
;
I $$USESSAN^RAHLRU1() S X="",Y=RACNDSP_" "_RAPRC,Y(0)="("_RAITY_" "_RATY_" "_RACPT_")"
I '$$USESSAN^RAHLRU1() S X="",Y=RACSE_" "_RAPRC,Y(0)="("_RAITY_" "_RATY_" "_RACPT_")"
S Y(0)=Y(0)_" "_$E($P($G(^RA(72,+$P(RA7003,"^",3),0)),"^"),1,4)
S $E(X,1,42)=Y,$E(X,44,70)=Y(0)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL15 5521 printed Oct 16, 2024@18:40:49 Page 2
RAUTL15 ;HISC/GJC-Skeleton rpt del if no data entered. ;13 Apr 2018 3:37 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**5,10,47,144**;Mar 16, 1998;Build 1
EN3(IEN74) ;Delete the skeleton report and pointer from Rad Pt file to
+1 ; report if user has not entered any report data (i.e. user ^'d out
+2 ; of report entry/edit after the system created a skeleton record).
+3 ; If the report is deleted, a bulletin will not be generated!
+4 NEW RA,RAPRG74,RATXT
+5 SET RA(0)=$GET(^RARPT(IEN74,0))
if RA(0)']""
QUIT 0
+6 IF $ORDER(^RARPT(IEN74,2005,0))>0
QUIT 0
+7 SET RA("I")=$SELECT(+$ORDER(^RARPT(IEN74,"I",0))'>0:1,1:0)
+8 SET RA("P")=$SELECT($GET(^RARPT(IEN74,"P"))="":1,1:0)
+9 SET RA("R")=$SELECT(+$ORDER(^RARPT(IEN74,"R",0))'>0:1,1:0)
+10 SET RA(5)=$PIECE(RA(0),"^",5)
SET RA(5)=$SELECT(RA(5)]"":RA(5),1:"Null")
+11 IF $LENGTH(RA(0),"^")'>6
IF ("dD"[RA(5))
IF (RA("I"))
IF (RA("P"))
IF (RA("R"))
Begin DoDot:1
+12 NEW %,D,D0,DA,DIC,DIE,DIK,DQ,DR,X,Y
+13 ; +++++ Delete Report Text pointer from the Examinations +++++
+14 ; +++++ multiple in the Rad/Nuc Med Patient file +++++
+15 ; +++++ if the data is xrefed, delete xref +++++
+16 ; del other print member's REPORT TEXT xrefs, & set ptr to #74 as null
+17 DO DEL17^RARTE2(IEN74)
+18 ; set RADFN, RADTI & RACNI if not defined! This situation will arise
+19 ; when this code finds an incomplete Rad/Nuc Med Report while running
+20 ; the post-init portion of the software.
+21 if '$DATA(RADFN)
SET RADFN=$PIECE(RA(0),"^",2)
+22 if '$DATA(RADTI)
SET RADTI=9999999.9999-$PIECE(RA(0),"^",3)
+23 if '$DATA(RACNI)
SET RACNI=+$ORDER(^RADPT(RADFN,"DT",RADTI,"P","B",+$PIECE(RA(0),"^",4),0))
+24 SET DA(2)=RADFN
SET DA(1)=RADTI
SET DA=RACNI
+25 DO ENKILL^RAXREF(70.03,17,IEN74,.DA)
+26 ; Delete pointers to the Rad/Nuc Med Report file i.e, '^RARPT('
+27 ;*******
+28 SET $PIECE(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=""
KILL DA,X
+29 ; +++++ Delete Report pntr from the Reports multiple in +++++
+30 ; +++++ the Reports Batches file +++++
+31 ; +++++ Delete Report pntr from the Report Distribution file +++++
+32 DO UPDTPNT^RAUTL9(IEN74)
+33 ; +++++ Delete the entry from the Rad/Nuc Med Reports file +++++
+34 SET DA=IEN74
SET DIK="^RARPT("
DO ^DIK
+35 SET RATXT(1)=" "
+36 SET RATXT(2)=" Report not complete. Must Delete......deletion complete!"
+37 SET RATXT(3)=$CHAR(7)
DO MES^XPDUTL(.RATXT)
+38 QUIT
End DoDot:1
QUIT 1
+39 QUIT 0
KMV ; kill miscellaneous variables
+1 KILL %DT,%I,%RET,%T
+2 KILL D,D0,D1,D2,D3,DA,DDER,DDH,DI,DIE,DIFLD,DIG,DIH,DISYS,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DG,DK,DL,DM,DN,DR
+3 KILL POP
+4 QUIT
+5 ;
CZECH(Y) ; check if an order can be cancelled, held, or scheduled.
+1 ; Y -> ien of the Rad/Nuc Med Orders file.
+2 ; Y1 -> if OE/RR > 2.5 & no order number: 1, else 0
+3 ; Called from: VALORD subroutine
+4 NEW RAORDER,Y1
SET Y1=0
+5 SET RAORDER(0)=$GET(^RAO(75.1,+Y,0))
if RAORDER(0)']""
QUIT
+6 IF '$PIECE(RAORDER(0),U,7)
IF (+$$ORVR^RAORDU()>2.5)
Begin DoDot:1
+7 ; 'Y2' is the procedure name
NEW Y2
+8 SET Y1=1
SET Y2=$PIECE($GET(^RAMIS(71,+$PIECE(RAORDER(0),U,2),0)),U)
+9 DO INV(RAOPTN,Y2)
+10 QUIT
End DoDot:1
+11 QUIT Y1
INV(X,X1) ; invalid action message called from the schedule/cancel or hold
+1 ; request options.
+2 ; X -> point of orgin (option) X1 -> procedure name
+3 ; Called from: CZECH subroutine
+4 SET X=$$UP^XLFSTR($EXTRACT(X,1,3))
SET X1=$SELECT(X1]"":X1,1:"Unknown")
+5 WRITE !!?3,"Sorry, can't "_$SELECT(X="SCH":"schedule",X="CAN":"cancel",1:"hold")
+6 WRITE " this request until OE/RR assigns an order number"
+7 WRITE !?3,"for procedure: ",X1,!?3,"Please try later!"
+8 QUIT
VALORD ; validate order data, i.e, has OE/RR order # and the site is running
+1 ; a version of OE/RR > 2.5 Called from: 2^RAORD, 3^RAORD & 4^RAORD
+2 NEW G1,G2,RA751
SET G1=0
+3 FOR
SET G1=$ORDER(RAORDS(G1))
if G1'>0
QUIT
Begin DoDot:1
+4 SET G2=$$CZECH(+$GET(RAORDS(G1)))
if G2
KILL RAORDS(G1)
+5 QUIT
End DoDot:1
+6 QUIT
DPROC(RADFN,RADTI,RACNI,RAOIFN) ; Determine if the ordered procedure is
+1 ; different from the registered procedure.
+2 ; Input Variables: RADFN-Patient DFN
+3 ; RADTI-inverse DT of exam (if exists)
+4 ; RACNI-IEN on the case node (if exists)
+5 ; RAOIFN-IEN of the order
+6 ; Output: null-procedures don't differ -OR- no order/exam
+7 ; not null-ordered proc_"^"_registered proc data
+8 ; registered procedure data includes imaging type, procedure
+9 ; type and CPT codes (if any)
+10 ;
+11 ; NOTE: The only time we don't set ^TMP($J,"RA DIFF PRC") is when
+12 ; we are using the 'Detailed Request Display' option and the ordered
+13 ; procedure is the same as the registered procedure. All other
+14 ; Request display options output the ordered procedure, the
+15 ; registered procedure and exam case number if the order
+16 ; is active.
+17 ;
+18 NEW RA7003,RA751
+19 SET RA7003=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+20 SET RA751=$GET(^RAO(75.1,RAOIFN,0))
+21 ; missing order or xam
if $PIECE(RA7003,"^",2)=""!($PIECE(RA751,"^",2)="")
QUIT ""
+22 ;KLM/P144 - removed condition for procedure change. Save it off no matter what
+23 NEW RA71,RACPT,RACSE,RAITY,RAPRC,RATY,X,Y
+24 SET RACSE=$$RJ^XLFSTR($PIECE(RA7003,"^"),5)
+25 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+26 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACSE)
+27 SET RA71=$GET(^RAMIS(71,$PIECE(RA7003,"^",2),0))
+28 SET RACPT=$PIECE($$NAMCODE^RACPTMSC(+$PIECE(RA71,"^",9),DT),"^")
+29 SET RAPRC=$EXTRACT($$GET1^DIQ(71,+$PIECE(RA7003,"^",2)_",",.01),1,36)
+30 SET RAITY=$$GET1^DIQ(79.2,+$PIECE(RA71,"^",12)_",",3)
+31 SET RATY=$$GET1^DIQ(71,$PIECE(RA7003,"^",2)_",",6)
+32 SET RATY=$EXTRACT(RATY,1)_$$LOW^XLFSTR($EXTRACT(RATY,2,9999))
+33 ;
+34 IF $$USESSAN^RAHLRU1()
SET X=""
SET Y=RACNDSP_" "_RAPRC
SET Y(0)="("_RAITY_" "_RATY_" "_RACPT_")"
+35 IF '$$USESSAN^RAHLRU1()
SET X=""
SET Y=RACSE_" "_RAPRC
SET Y(0)="("_RAITY_" "_RATY_" "_RACPT_")"
+36 SET Y(0)=Y(0)_" "_$EXTRACT($PIECE($GET(^RA(72,+$PIECE(RA7003,"^",3),0)),"^"),1,4)
+37 SET $EXTRACT(X,1,42)=Y
SET $EXTRACT(X,44,70)=Y(0)
+38 QUIT X
