- RAUTL18 ;HISC/DAD,GJC - PROCEDURE FILE UTILITIES ; Mar 11, 2024@08:19:32
- ;;5.0;Radiology/Nuclear Medicine;**208**;Mar 16, 1998;Build 4
- EN(RAPROCD0,PROCTYPE) ;
- ; Check/delete DESCENDENT multiple when the TYPE OF PROCEDURE changes
- ; Input: PROCEDURE file (#71) IEN (RAPROCD0)
- ; New TYPE OF PROCEDURE value in internal format (PROCTYPE)
- ;
- QUIT 0
- ;RA*5.0*208: This tag, EN, is called from the RIS' Procedure
- ;file (#71). The Type of Procedure (#6) field's input transform
- ;will not be executed. The input transform will be updated in a
- ;future radiology patch.
- ;
- I PROCTYPE="P" G EN1
- I PROCTYPE'="P" G EN2
- ;
- EN1 ; TYPE OF PROCEDURE: Non-parent ==> Parent
- ; Is PROCEDURE a DESCENDENT? If it is KILL X
- ; Input: PROCEDURE file (#71) IEN (RAPROCD0)
- N RACNT,RAEXIT,RAPARENT,RATXT,X,Y
- S (RAPARENT,RAEXIT)=0,RACNT=101
- F S RAPARENT=$O(^RAMIS(71,"ADESC",RAPROCD0,RAPARENT)) Q:RAPARENT'>0 D
- . S RAPARENT(0)=$P($G(^RAMIS(71,RAPARENT,0)),U)
- . I RAPARENT(0)]"" S RATXT(RACNT)=$J("",14)_RAPARENT(0),RACNT=RACNT+1
- . Q
- I $O(RATXT(0)) D S RAEXIT=1
- . S RATXT(RACNT)=""
- . S RATXT(1)=""
- . S RATXT(2)="This procedure may not be changed to a parent procedure"
- . S RATXT(3)="because it is already a descendent of the following"
- . S RATXT(4)="procedure(s):"
- . D EN^DDIOL(.RATXT)
- . Q
- Q RAEXIT
- ;
- EN2 ; TYPE OF PROCEDURE: Parent ==> Non-parent, delete DESCENDENTS
- ; Input: PROCEDURE file (#71) IEN (RAPROCD0)
- N D0,D1,DA,RADESCD0,RAFDA,RATXT,RAXREF,X,Y
- I $O(^RAMIS(71,RAPROCD0,4,0))'>0 Q 0
- D EN^DDIOL(" Deleting descendents of this procedure."_$C(7))
- S RADESCD0=0
- F S RADESCD0=$O(^RAMIS(71,RAPROCD0,4,RADESCD0)) Q:RADESCD0'>0 D
- . S RAPROC=$P($G(^RAMIS(71,RAPROCD0,4,RADESCD0,0)),U) Q:RAPROC=""
- . S RAXREF=0
- . F S RAXREF=$O(^DD(71.05,.01,1,RAXREF)) Q:RAXREF'>0 D
- .. S X=RAPROC,(D0,DA(1))=RAPROCD0,(D1,DA)=RADESCD0
- .. I $G(^DD(71.05,.01,1,RAXREF,2))]"" X ^(2)
- .. Q
- . K ^RAMIS(71,RAPROCD0,4,RADESCD0)
- . Q
- K ^RAMIS(71,RAPROCD0,4,0)
- Q 0
- EN3(RADA) ; Displays the available sequence numbers for the current
- ;imaging type during the Common Procedure Edit option when editing
- ;the Sequence Number fld of file 71.3
- Q:'$D(RACCESS)!('$D(RAMDIV))!('$D(RAMDV))!('$D(RAMLC))
- ; proceed only if entering through Rad/Nuc Med
- Q:'RAIMGTYI ; Quit if not present
- N RA,RA0,RACNT,RAFLG,RAHIT,RALOWER,RAUPPER,RAIMGTYJ D HOME^%ZIS
- S (RAFLG,RAHIT)=0,RAIMGTYJ=$P($G(^RA(79.2,+RAIMGTYI,0)),"^")
- S RA0=$G(^RAMIS(71.3,RADA,0)),RACNT=1
- S RALOWER=1,RAUPPER=40 ; upper and lower limits, decimals not allowed
- W !?3,"Available Sequence Numbers for "_RAIMGTYJ_":"
- F RA=RALOWER:1:RAUPPER D
- . Q:$D(^RAMIS(71.3,"AA",RAIMGTYI,RA))
- . S:RAHIT=0 RAHIT=RA
- . I ($L($G(RA(RACNT))_RA_", ")+3)>IOM D
- .. S RA(RACNT)=$P(RA(RACNT),", ",1,$L(RA(RACNT),", ")-1)
- .. S RACNT=RACNT+1
- .. Q
- . S RA(RACNT)=$G(RA(RACNT))_RA_", "
- . Q
- S:RAHIT RA(RACNT)=$P(RA(RACNT),", ",1,$L(RA(RACNT),", ")-1)_"."
- I 'RAHIT D Q
- . I +$P(RA0,"^",4) D
- .. W !!?5,"The only valid sequence number for an Imaging Type of"
- .. W !?5,"'"_RAIMGTYJ_"' is: ",$P(RA0,"^",4)_".",!
- .. Q
- . E W !!?5,"There are no available sequence numbers.",!
- . Q
- S RACNT=0 F S RACNT=$O(RA(RACNT)) Q:RACNT'>0 W !,$G(RA(RACNT))
- W ! I +$P(RA0,"^",4) D
- . W !?5,"The current sequence number is: "_$P(RA0,"^",4)_"."
- . Q
- W !?5,"The"_$S(+$P(RA0,"^",4)&(+$P(RA0,"^",4)<RAHIT):" next",1:"")
- W " lowest available sequence number is: ",RAHIT,!
- Q
- BCDE(X) ; Output data in a barcode format. 'X' is the data to be converted.
- ; RAIND1 & RAIND2 are newed in PRT^RAFLH. Used for indirection.
- S RACNT=+$G(RACNT)+1
- I X']"" S RAIND1(RACNT)=X,RAIND2="RAIND1("_RACNT_")" Q RAIND2
- I IOBARON]"",(IOBAROFF]"") D
- . S RAIND1(RACNT)=X,RAIND2="@IOBARON,RAIND1("_RACNT_"),@IOBAROFF"
- . Q
- E S RAIND1(RACNT)="",RAIND2="RAIND1("_RACNT_")"
- Q RAIND2
- ILOC(X) ; Determines based on procedure I-Type if only one I-Loc is available
- ; for this user.
- ; To be called from: [RA OERR EDIT], [RA ORDER EXAM] and
- ; [RA QUICK EXAM ORDER] input templates. (File: 75.1)
- ; Input Variable: 'X'-> IEN of the procedure
- ; Output Variable: 'Y'-> $S(one I-Loc of proc. I-Type: IEN of I-Loc,1:0)
- Q:X=0 0
- Q:'($D(^RAMIS(71,X,0))#2) 0
- N RA791,RACNT,RAPROI,RASAV
- S (RA791,RACNT)=0,RAPROI=+$P($G(^RAMIS(71,X,0)),"^",12) Q:'RAPROI 0
- F S RA791=$O(^RA(79.1,"BIMG",RAPROI,RA791)) Q:RA791'>0 D Q:RACNT'<2
- . Q:$P($G(^RA(79.1,RA791,0)),"^",19)]"" ; inactive
- . S RACNT=RACNT+1,RASAV=RA791
- . Q
- W:RACNT=1 !?5,"...request submitted to: ",$P($G(^SC(+$P($G(^RA(79.1,RASAV,0)),"^"),0)),"^")
- Q $S(RACNT=1:RASAV,1:0)
- ADDRESS(RADA,DFN) ; Pass back the address of the patient for Print Label
- ; Fields.
- ; Input: RADA-ien of the print label field, DFN-patient ien
- ; Output: The street address of the patient.
- ; It can be the street address(123 Main Street), possibly followed by
- ; additional street address information such as 'P.O. Box' data, and
- ; finally the city, state, and zip code.
- Q:+DFN=0 "" Q:'$D(^RA(78.7,RADA,0))#2 ""
- N VAERR,VAPA,X S X="" D ADD^VADPT Q:VAERR ""
- I $D(^RA(78.7,"B","PATIENT ADDRESS LINE 1",RADA)) D
- . S X=VAPA(1) ; 1st line of street address
- . Q
- I $D(^RA(78.7,"B","PATIENT ADDRESS LINE 2",RADA)) D
- . S X=VAPA(2)_" "_VAPA(3) S:X=" " X="" ; 2nd & 3rd lines together
- . Q
- I $D(^RA(78.7,"B","PATIENT ADDRESS LINE 3",RADA)) D
- . ; city, street and zip information (prefer ZIP+4, else regular ZIP)
- . N RABBR S RABBR=$P($G(^DIC(5,+VAPA(5),0)),"^",2)
- . S X=VAPA(4)_" "_$S(RABBR]"":RABBR,1:$P(VAPA(5),"^",2))
- . S X=X_" "_$S($P(VAPA(11),"^",2)]"":$P(VAPA(11),"^",2),1:VAPA(6))
- . Q
- Q $TR(X,",."," ")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL18 5690 printed Feb 19, 2025@00:06:34 Page 2
- RAUTL18 ;HISC/DAD,GJC - PROCEDURE FILE UTILITIES ; Mar 11, 2024@08:19:32
- +1 ;;5.0;Radiology/Nuclear Medicine;**208**;Mar 16, 1998;Build 4
- EN(RAPROCD0,PROCTYPE) ;
- +1 ; Check/delete DESCENDENT multiple when the TYPE OF PROCEDURE changes
- +2 ; Input: PROCEDURE file (#71) IEN (RAPROCD0)
- +3 ; New TYPE OF PROCEDURE value in internal format (PROCTYPE)
- +4 ;
- +5 QUIT 0
- +6 ;RA*5.0*208: This tag, EN, is called from the RIS' Procedure
- +7 ;file (#71). The Type of Procedure (#6) field's input transform
- +8 ;will not be executed. The input transform will be updated in a
- +9 ;future radiology patch.
- +10 ;
- +11 IF PROCTYPE="P"
- GOTO EN1
- +12 IF PROCTYPE'="P"
- GOTO EN2
- +13 ;
- EN1 ; TYPE OF PROCEDURE: Non-parent ==> Parent
- +1 ; Is PROCEDURE a DESCENDENT? If it is KILL X
- +2 ; Input: PROCEDURE file (#71) IEN (RAPROCD0)
- +3 NEW RACNT,RAEXIT,RAPARENT,RATXT,X,Y
- +4 SET (RAPARENT,RAEXIT)=0
- SET RACNT=101
- +5 FOR
- SET RAPARENT=$ORDER(^RAMIS(71,"ADESC",RAPROCD0,RAPARENT))
- if RAPARENT'>0
- QUIT
- Begin DoDot:1
- +6 SET RAPARENT(0)=$PIECE($GET(^RAMIS(71,RAPARENT,0)),U)
- +7 IF RAPARENT(0)]""
- SET RATXT(RACNT)=$JUSTIFY("",14)_RAPARENT(0)
- SET RACNT=RACNT+1
- +8 QUIT
- End DoDot:1
- +9 IF $ORDER(RATXT(0))
- Begin DoDot:1
- +10 SET RATXT(RACNT)=""
- +11 SET RATXT(1)=""
- +12 SET RATXT(2)="This procedure may not be changed to a parent procedure"
- +13 SET RATXT(3)="because it is already a descendent of the following"
- +14 SET RATXT(4)="procedure(s):"
- +15 DO EN^DDIOL(.RATXT)
- +16 QUIT
- End DoDot:1
- SET RAEXIT=1
- +17 QUIT RAEXIT
- +18 ;
- EN2 ; TYPE OF PROCEDURE: Parent ==> Non-parent, delete DESCENDENTS
- +1 ; Input: PROCEDURE file (#71) IEN (RAPROCD0)
- +2 NEW D0,D1,DA,RADESCD0,RAFDA,RATXT,RAXREF,X,Y
- +3 IF $ORDER(^RAMIS(71,RAPROCD0,4,0))'>0
- QUIT 0
- +4 DO EN^DDIOL(" Deleting descendents of this procedure."_$CHAR(7))
- +5 SET RADESCD0=0
- +6 FOR
- SET RADESCD0=$ORDER(^RAMIS(71,RAPROCD0,4,RADESCD0))
- if RADESCD0'>0
- QUIT
- Begin DoDot:1
- +7 SET RAPROC=$PIECE($GET(^RAMIS(71,RAPROCD0,4,RADESCD0,0)),U)
- if RAPROC=""
- QUIT
- +8 SET RAXREF=0
- +9 FOR
- SET RAXREF=$ORDER(^DD(71.05,.01,1,RAXREF))
- if RAXREF'>0
- QUIT
- Begin DoDot:2
- +10 SET X=RAPROC
- SET (D0,DA(1))=RAPROCD0
- SET (D1,DA)=RADESCD0
- +11 IF $GET(^DD(71.05,.01,1,RAXREF,2))]""
- XECUTE ^(2)
- +12 QUIT
- End DoDot:2
- +13 KILL ^RAMIS(71,RAPROCD0,4,RADESCD0)
- +14 QUIT
- End DoDot:1
- +15 KILL ^RAMIS(71,RAPROCD0,4,0)
- +16 QUIT 0
- EN3(RADA) ; Displays the available sequence numbers for the current
- +1 ;imaging type during the Common Procedure Edit option when editing
- +2 ;the Sequence Number fld of file 71.3
- +3 if '$DATA(RACCESS)!('$DATA(RAMDIV))!('$DATA(RAMDV))!('$DATA(RAMLC))
- QUIT
- +4 ; proceed only if entering through Rad/Nuc Med
- +5 ; Quit if not present
- if 'RAIMGTYI
- QUIT
- +6 NEW RA,RA0,RACNT,RAFLG,RAHIT,RALOWER,RAUPPER,RAIMGTYJ
- DO HOME^%ZIS
- +7 SET (RAFLG,RAHIT)=0
- SET RAIMGTYJ=$PIECE($GET(^RA(79.2,+RAIMGTYI,0)),"^")
- +8 SET RA0=$GET(^RAMIS(71.3,RADA,0))
- SET RACNT=1
- +9 ; upper and lower limits, decimals not allowed
- SET RALOWER=1
- SET RAUPPER=40
- +10 WRITE !?3,"Available Sequence Numbers for "_RAIMGTYJ_":"
- +11 FOR RA=RALOWER:1:RAUPPER
- Begin DoDot:1
- +12 if $DATA(^RAMIS(71.3,"AA",RAIMGTYI,RA))
- QUIT
- +13 if RAHIT=0
- SET RAHIT=RA
- +14 IF ($LENGTH($GET(RA(RACNT))_RA_", ")+3)>IOM
- Begin DoDot:2
- +15 SET RA(RACNT)=$PIECE(RA(RACNT),", ",1,$LENGTH(RA(RACNT),", ")-1)
- +16 SET RACNT=RACNT+1
- +17 QUIT
- End DoDot:2
- +18 SET RA(RACNT)=$GET(RA(RACNT))_RA_", "
- +19 QUIT
- End DoDot:1
- +20 if RAHIT
- SET RA(RACNT)=$PIECE(RA(RACNT),", ",1,$LENGTH(RA(RACNT),", ")-1)_"."
- +21 IF 'RAHIT
- Begin DoDot:1
- +22 IF +$PIECE(RA0,"^",4)
- Begin DoDot:2
- +23 WRITE !!?5,"The only valid sequence number for an Imaging Type of"
- +24 WRITE !?5,"'"_RAIMGTYJ_"' is: ",$PIECE(RA0,"^",4)_".",!
- +25 QUIT
- End DoDot:2
- +26 IF '$TEST
- WRITE !!?5,"There are no available sequence numbers.",!
- +27 QUIT
- End DoDot:1
- QUIT
- +28 SET RACNT=0
- FOR
- SET RACNT=$ORDER(RA(RACNT))
- if RACNT'>0
- QUIT
- WRITE !,$GET(RA(RACNT))
- +29 WRITE !
- IF +$PIECE(RA0,"^",4)
- Begin DoDot:1
- +30 WRITE !?5,"The current sequence number is: "_$PIECE(RA0,"^",4)_"."
- +31 QUIT
- End DoDot:1
- +32 WRITE !?5,"The"_$SELECT(+$PIECE(RA0,"^",4)&(+$PIECE(RA0,"^",4)<RAHIT):" next",1:"")
- +33 WRITE " lowest available sequence number is: ",RAHIT,!
- +34 QUIT
- BCDE(X) ; Output data in a barcode format. 'X' is the data to be converted.
- +1 ; RAIND1 & RAIND2 are newed in PRT^RAFLH. Used for indirection.
- +2 SET RACNT=+$GET(RACNT)+1
- +3 IF X']""
- SET RAIND1(RACNT)=X
- SET RAIND2="RAIND1("_RACNT_")"
- QUIT RAIND2
- +4 IF IOBARON]""
- IF (IOBAROFF]"")
- Begin DoDot:1
- +5 SET RAIND1(RACNT)=X
- SET RAIND2="@IOBARON,RAIND1("_RACNT_"),@IOBAROFF"
- +6 QUIT
- End DoDot:1
- +7 IF '$TEST
- SET RAIND1(RACNT)=""
- SET RAIND2="RAIND1("_RACNT_")"
- +8 QUIT RAIND2
- ILOC(X) ; Determines based on procedure I-Type if only one I-Loc is available
- +1 ; for this user.
- +2 ; To be called from: [RA OERR EDIT], [RA ORDER EXAM] and
- +3 ; [RA QUICK EXAM ORDER] input templates. (File: 75.1)
- +4 ; Input Variable: 'X'-> IEN of the procedure
- +5 ; Output Variable: 'Y'-> $S(one I-Loc of proc. I-Type: IEN of I-Loc,1:0)
- +6 if X=0
- QUIT 0
- +7 if '($DATA(^RAMIS(71,X,0))#2)
- QUIT 0
- +8 NEW RA791,RACNT,RAPROI,RASAV
- +9 SET (RA791,RACNT)=0
- SET RAPROI=+$PIECE($GET(^RAMIS(71,X,0)),"^",12)
- if 'RAPROI
- QUIT 0
- +10 FOR
- SET RA791=$ORDER(^RA(79.1,"BIMG",RAPROI,RA791))
- if RA791'>0
- QUIT
- Begin DoDot:1
- +11 ; inactive
- if $PIECE($GET(^RA(79.1,RA791,0)),"^",19)]""
- QUIT
- +12 SET RACNT=RACNT+1
- SET RASAV=RA791
- +13 QUIT
- End DoDot:1
- if RACNT'<2
- QUIT
- +14 if RACNT=1
- WRITE !?5,"...request submitted to: ",$PIECE($GET(^SC(+$PIECE($GET(^RA(79.1,RASAV,0)),"^"),0)),"^")
- +15 QUIT $SELECT(RACNT=1:RASAV,1:0)
- ADDRESS(RADA,DFN) ; Pass back the address of the patient for Print Label
- +1 ; Fields.
- +2 ; Input: RADA-ien of the print label field, DFN-patient ien
- +3 ; Output: The street address of the patient.
- +4 ; It can be the street address(123 Main Street), possibly followed by
- +5 ; additional street address information such as 'P.O. Box' data, and
- +6 ; finally the city, state, and zip code.
- +7 if +DFN=0
- QUIT ""
- if '$DATA(^RA(78.7,RADA,0))#2
- QUIT ""
- +8 NEW VAERR,VAPA,X
- SET X=""
- DO ADD^VADPT
- if VAERR
- QUIT ""
- +9 IF $DATA(^RA(78.7,"B","PATIENT ADDRESS LINE 1",RADA))
- Begin DoDot:1
- +10 ; 1st line of street address
- SET X=VAPA(1)
- +11 QUIT
- End DoDot:1
- +12 IF $DATA(^RA(78.7,"B","PATIENT ADDRESS LINE 2",RADA))
- Begin DoDot:1
- +13 ; 2nd & 3rd lines together
- SET X=VAPA(2)_" "_VAPA(3)
- if X=" "
- SET X=""
- +14 QUIT
- End DoDot:1
- +15 IF $DATA(^RA(78.7,"B","PATIENT ADDRESS LINE 3",RADA))
- Begin DoDot:1
- +16 ; city, street and zip information (prefer ZIP+4, else regular ZIP)
- +17 NEW RABBR
- SET RABBR=$PIECE($GET(^DIC(5,+VAPA(5),0)),"^",2)
- +18 SET X=VAPA(4)_" "_$SELECT(RABBR]"":RABBR,1:$PIECE(VAPA(5),"^",2))
- +19 SET X=X_" "_$SELECT($PIECE(VAPA(11),"^",2)]"":$PIECE(VAPA(11),"^",2),1:VAPA(6))
- +20 QUIT
- End DoDot:1
- +21 QUIT $TRANSLATE(X,",."," ")
