RAMAGU03 ;HCIOFO/SG - ORDERS/EXAMS API (PROCEDURE UTILITIES) ; 2/24/09 3:44pm
;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
;
Q
;
;***** CHECKS RADIOLOGY PROCEDURE AND MODIFIERS
;
; RAPROC Radiology procedure and modifiers
; ^01: Procedure IEN in file #71
; ^02: Optional procedure modifiers (IENs in
; ... the PROCEDURE MODIFIERS file (#71.2))
; ^nn:
;
; RAIMGTYI Imaging type IEN (file #79.2) of the order/exam.
;
; RADTE Date for procedure status check (active/inactive).
;
; [PROCTYPE] If this parameter is defined and has a non-empty
; value, then only referenced types of procedures
; are allowed (see the TYPE OF PROCEDURE field (6)
; of the RAD/NUC MED PROCEDURES file (#71) for more
; details).
;
; B Broad
; D Detailed
; P Parent
; S Series
;
; For example, "BD" will allow 'broad' or 'detailed'
; procedures but exclude 'series' and 'parent' ones.
;
; By default ($G(PROCTYPE)=""), all procedures are
; allowed.
;
; Return values:
; <0 Error descriptor (see $$ERROR^RAERR)
; 0 Procedure and modifiers are valid
;
CHKPROC(RAPROC,RAIMGTYI,RADTE,PROCTYPE) ;
N ERRCNT,I,IENS,L,RABUF,RAMSG,RAINFO,RAMINFO,RC,TMP
S ERRCNT=0,RAINFO="Procedure IEN: "_(+RAPROC)
;
;=== Radiology procedure IEN
I RAPROC>0 S RC=0 D S:RC<0 ERRCNT=ERRCNT+1
. S IENS=(+RAPROC)_","
. D GETS^DIQ(71,IENS,".01;6;12;100","I","RABUF","RAMSG")
. I $G(DIERR) S RC=$$DBS^RAERR("RAMSG",-9,71,IENS) Q
. S TMP=$G(RABUF(71,IENS,.01,"I"))
. S:TMP'="" RAINFO="Procedure: '"_TMP_"' (IEN="_(+RAPROC)_")"
. ;--- Imaging type IEN
. S TMP=+$G(RABUF(71,IENS,12,"I"))
. I TMP'>0 S RC=$$ERROR^RAERR(-19,,71,IENS,12) Q
. ;--- Check if the procedure has required imaging type
. I TMP'=RAIMGTYI S RC=$$ERROR^RAERR(-12) Q
. ;--- Check if the procedure is/was active on requested date
. S TMP=$G(RABUF(71,IENS,100,"I"))\1
. I TMP>0,TMP<(RADTE\1) D Q
. . S RC=$$ERROR^RAERR(-17,,$$FMTE^XLFDT(RADTE))
. ;--- Check the procedure type if necessary
. D:$G(PROCTYPE)'=""
. . S TMP=$G(RABUF(71,IENS,6,"I"))
. . I TMP'="" Q:PROCTYPE[TMP
. . S RC=$$ERROR^RAERR(-18,,TMP)
E D ERROR^RAERR(-21,,$P(RAPROC,U)) S ERRCNT=ERRCNT+1
;
;=== Procedure modifier IENs
S L=$L(RAPROC,U)
F I=2:1:L S TMP=$P(RAPROC,U,I),RC=0 D S:RC<0 ERRCNT=ERRCNT+1
. Q:TMP=""
. I TMP'>0 S RC=$$ERROR^RAERR(-22,,TMP) Q
. S IENS=(+TMP)_",",TMP=$$GET1^DIQ(71.2,IENS,.01,,,"RAMSG")
. I $G(DIERR) S RC=$$DBS^RAERR("RAMSG",-9,71.2,IENS) Q
. I TMP="" S RC=$$ERROR^RAERR(-19,,71.2,IENS,.01) Q
. S RAMINFO="Procedure modifier: '"_TMP_"' (IEN="_(+IENS)_")"
. ;--- Check the imaging type
. I $O(^RAMIS(71.2,"AB",RAIMGTYI,+IENS,0))'>0 D Q
. . S RC=$$ERROR^RAERR(-39,RAMINFO)
;
;===
Q $S(ERRCNT>0:$$ERROR^RAERR(-20,RAINFO),1:0)
;
;***** TRANSLATES A PARENT PROCEDURE INTO THE LIST OF DESCENDENTS
;
; RAPIEN IEN of a Radiology procedure in file #71
;
; .RAPLST Reference to a local array where IENs and names
; of descendent procedures are returned to:
; RAPLST(Seq#)=IEN^Name
;
; [.SNGLRPT] Reference to a local variable that will reflect the
; value of the SINGLE REPORT field (18) of the parent
; procedure (1 for YES, 0 otherwise).
;
; Return values:
; <0 Error descriptor (see $$ERROR^RAERR)
; 0 Procedure defined by the RAPIEN is not a parent one
; >0 Number of descendents in the RAPLST array
;
DESCPLST(RAPIEN,RAPLST,SNGLRPT) ;
N CNT,IENS,RABUF,RAMSG,RC,TMP
K RAPLST S SNGLRPT=0
;--- Get the procedure data
S IENS=RAPIEN_","
D GETS^DIQ(71,IENS,"6;18;300*","IE","RABUF","RAMSG")
Q:$G(DIERR) $$DBS^RAERR("RAMSG",-9,71,IENS)
;--- Quit if not a "parent" procedure
Q:$G(RABUF(71,IENS,6,"I"))'="P" 0
;--- Single report
S:$G(RABUF(71,IENS,18,"I"))="Y" SNGLRPT=1
;--- Compile the list of descendents
S IENS="",CNT=0
F S IENS=$O(RABUF(71.05,IENS)) Q:IENS="" D
. S TMP=+$G(RABUF(71.05,IENS,.01,"I"))
. I TMP'>0 S RC=$$ERROR^RAERR(-19,,71.05,IENS,.01) Q
. S CNT=CNT+1
. S RAPLST(CNT)=TMP_U_$G(RABUF(71.05,IENS,.01,"E"))
;---
Q CNT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAMAGU03 4485 printed Nov 22, 2024@17:46:58 Page 2
RAMAGU03 ;HCIOFO/SG - ORDERS/EXAMS API (PROCEDURE UTILITIES) ; 2/24/09 3:44pm
+1 ;;5.0;Radiology/Nuclear Medicine;**90**;Mar 16, 1998;Build 20
+2 ;
+3 QUIT
+4 ;
+5 ;***** CHECKS RADIOLOGY PROCEDURE AND MODIFIERS
+6 ;
+7 ; RAPROC Radiology procedure and modifiers
+8 ; ^01: Procedure IEN in file #71
+9 ; ^02: Optional procedure modifiers (IENs in
+10 ; ... the PROCEDURE MODIFIERS file (#71.2))
+11 ; ^nn:
+12 ;
+13 ; RAIMGTYI Imaging type IEN (file #79.2) of the order/exam.
+14 ;
+15 ; RADTE Date for procedure status check (active/inactive).
+16 ;
+17 ; [PROCTYPE] If this parameter is defined and has a non-empty
+18 ; value, then only referenced types of procedures
+19 ; are allowed (see the TYPE OF PROCEDURE field (6)
+20 ; of the RAD/NUC MED PROCEDURES file (#71) for more
+21 ; details).
+22 ;
+23 ; B Broad
+24 ; D Detailed
+25 ; P Parent
+26 ; S Series
+27 ;
+28 ; For example, "BD" will allow 'broad' or 'detailed'
+29 ; procedures but exclude 'series' and 'parent' ones.
+30 ;
+31 ; By default ($G(PROCTYPE)=""), all procedures are
+32 ; allowed.
+33 ;
+34 ; Return values:
+35 ; <0 Error descriptor (see $$ERROR^RAERR)
+36 ; 0 Procedure and modifiers are valid
+37 ;
CHKPROC(RAPROC,RAIMGTYI,RADTE,PROCTYPE) ;
+1 NEW ERRCNT,I,IENS,L,RABUF,RAMSG,RAINFO,RAMINFO,RC,TMP
+2 SET ERRCNT=0
SET RAINFO="Procedure IEN: "_(+RAPROC)
+3 ;
+4 ;=== Radiology procedure IEN
+5 IF RAPROC>0
SET RC=0
Begin DoDot:1
+6 SET IENS=(+RAPROC)_","
+7 DO GETS^DIQ(71,IENS,".01;6;12;100","I","RABUF","RAMSG")
+8 IF $GET(DIERR)
SET RC=$$DBS^RAERR("RAMSG",-9,71,IENS)
QUIT
+9 SET TMP=$GET(RABUF(71,IENS,.01,"I"))
+10 if TMP'=""
SET RAINFO="Procedure: '"_TMP_"' (IEN="_(+RAPROC)_")"
+11 ;--- Imaging type IEN
+12 SET TMP=+$GET(RABUF(71,IENS,12,"I"))
+13 IF TMP'>0
SET RC=$$ERROR^RAERR(-19,,71,IENS,12)
QUIT
+14 ;--- Check if the procedure has required imaging type
+15 IF TMP'=RAIMGTYI
SET RC=$$ERROR^RAERR(-12)
QUIT
+16 ;--- Check if the procedure is/was active on requested date
+17 SET TMP=$GET(RABUF(71,IENS,100,"I"))\1
+18 IF TMP>0
IF TMP<(RADTE\1)
Begin DoDot:2
+19 SET RC=$$ERROR^RAERR(-17,,$$FMTE^XLFDT(RADTE))
End DoDot:2
QUIT
+20 ;--- Check the procedure type if necessary
+21 if $GET(PROCTYPE)'=""
Begin DoDot:2
+22 SET TMP=$GET(RABUF(71,IENS,6,"I"))
+23 IF TMP'=""
if PROCTYPE[TMP
QUIT
+24 SET RC=$$ERROR^RAERR(-18,,TMP)
End DoDot:2
End DoDot:1
if RC<0
SET ERRCNT=ERRCNT+1
+25 IF '$TEST
DO ERROR^RAERR(-21,,$PIECE(RAPROC,U))
SET ERRCNT=ERRCNT+1
+26 ;
+27 ;=== Procedure modifier IENs
+28 SET L=$LENGTH(RAPROC,U)
+29 FOR I=2:1:L
SET TMP=$PIECE(RAPROC,U,I)
SET RC=0
Begin DoDot:1
+30 if TMP=""
QUIT
+31 IF TMP'>0
SET RC=$$ERROR^RAERR(-22,,TMP)
QUIT
+32 SET IENS=(+TMP)_","
SET TMP=$$GET1^DIQ(71.2,IENS,.01,,,"RAMSG")
+33 IF $GET(DIERR)
SET RC=$$DBS^RAERR("RAMSG",-9,71.2,IENS)
QUIT
+34 IF TMP=""
SET RC=$$ERROR^RAERR(-19,,71.2,IENS,.01)
QUIT
+35 SET RAMINFO="Procedure modifier: '"_TMP_"' (IEN="_(+IENS)_")"
+36 ;--- Check the imaging type
+37 IF $ORDER(^RAMIS(71.2,"AB",RAIMGTYI,+IENS,0))'>0
Begin DoDot:2
+38 SET RC=$$ERROR^RAERR(-39,RAMINFO)
End DoDot:2
QUIT
End DoDot:1
if RC<0
SET ERRCNT=ERRCNT+1
+39 ;
+40 ;===
+41 QUIT $SELECT(ERRCNT>0:$$ERROR^RAERR(-20,RAINFO),1:0)
+42 ;
+43 ;***** TRANSLATES A PARENT PROCEDURE INTO THE LIST OF DESCENDENTS
+44 ;
+45 ; RAPIEN IEN of a Radiology procedure in file #71
+46 ;
+47 ; .RAPLST Reference to a local array where IENs and names
+48 ; of descendent procedures are returned to:
+49 ; RAPLST(Seq#)=IEN^Name
+50 ;
+51 ; [.SNGLRPT] Reference to a local variable that will reflect the
+52 ; value of the SINGLE REPORT field (18) of the parent
+53 ; procedure (1 for YES, 0 otherwise).
+54 ;
+55 ; Return values:
+56 ; <0 Error descriptor (see $$ERROR^RAERR)
+57 ; 0 Procedure defined by the RAPIEN is not a parent one
+58 ; >0 Number of descendents in the RAPLST array
+59 ;
DESCPLST(RAPIEN,RAPLST,SNGLRPT) ;
+1 NEW CNT,IENS,RABUF,RAMSG,RC,TMP
+2 KILL RAPLST
SET SNGLRPT=0
+3 ;--- Get the procedure data
+4 SET IENS=RAPIEN_","
+5 DO GETS^DIQ(71,IENS,"6;18;300*","IE","RABUF","RAMSG")
+6 if $GET(DIERR)
QUIT $$DBS^RAERR("RAMSG",-9,71,IENS)
+7 ;--- Quit if not a "parent" procedure
+8 if $GET(RABUF(71,IENS,6,"I"))'="P"
QUIT 0
+9 ;--- Single report
+10 if $GET(RABUF(71,IENS,18,"I"))="Y"
SET SNGLRPT=1
+11 ;--- Compile the list of descendents
+12 SET IENS=""
SET CNT=0
+13 FOR
SET IENS=$ORDER(RABUF(71.05,IENS))
if IENS=""
QUIT
Begin DoDot:1
+14 SET TMP=+$GET(RABUF(71.05,IENS,.01,"I"))
+15 IF TMP'>0
SET RC=$$ERROR^RAERR(-19,,71.05,IENS,.01)
QUIT
+16 SET CNT=CNT+1
+17 SET RAPLST(CNT)=TMP_U_$GET(RABUF(71.05,IENS,.01,"E"))
End DoDot:1
+18 ;---
+19 QUIT CNT
