RANPRO ;BPFO/CLT - NEW RADIOLOGY PROCEDURE ; 27 Oct 2016 4:57 PM
;;5.0;Radiology/Nuclear Medicine;**127,138,150**;Mar 16, 1998;Build 2
;
; RA*5*150 INC1933636 Do not allow entry of a semi-colon (;)
EN ; Main entry point - driver for PROCEDURE prompt loop
;
N RANQUIT,RANHIT,RADIO,RAMIS,RAPTY,RAIMAG,RA65,RARMPF,RAEXC
S RANQUIT=0,RANHIT=0
F Q:$G(RANQUIT) D EN2
I $G(RANHIT) D 22^RAMAIN2
Q
;
EN2 ; Loop entry point for PROCEDURE prompt
N RACPT,RADA,RANM,RAPNM,RASEED,RATYP,RAX,RAYY,X,Y,RAMV,RACODE,RANEW,RAP3,RATYPE,I,RA7111DA
N RANEW71,ARY,A,B,C,D,E,F,RALRDA,RACMDIFF,RACTIVE,RAENALL,RAFILE,RAY,RAPROC,RASTAT,RATRKCMA,RAXTMPNM
N DD,DA,DO,DIC,DIR,DR,RAEND,RACODE1,RAOLDIEN,DIE,RANMSG,RATRKCMB,RADANEW1,RAFOUND,AA,EE
N DIK,XX,RADUZ,RAFN,RAINADT,RAS,XMDUN,DTOUT,DUOUT
S RANQUIT="",RANMSG="",RAMV=0
K ^XTMP("RAMAIN4",$J)
S (RANEW,RANEW71,RANQUIT)=0
F D Q:$G(RAFOUND)!$G(RANQUIT)!$G(RANEW)
.K X,Y,RAEND,DIR
.S DIR(0)="FUO^1:60",DIR("A",1)=" ",DIR("A")="RAD/NUC MED PROCEDURE NAME"
.S DIR("PRE")="S:$D(X) X=$$UP^XLFSTR(X) K:$L(X)>60 X S:$G(X)[""?"" X=-99"
.D ^DIR S:Y=-99 (X,Y)="?" S RANM=Y I X=""!(X["^") S RANQUIT=1 Q
.; RA*5*150 Added the next line
.I X[";" D EN^DDIOL("Entry must not contain a semi-colon ';' ",,"!?12,$C(7)") Q
.S RAPNM=RANM
.K Y D SEARCH(RAPNM,.Y)
.Q:(Y="")!(Y<0)!(Y="?")
.S (RAPNM,RANM)=Y
.I $G(Y)>0&$L($P(Y,"^",2)) S RAFOUND=1 D Q ; Match found
.. I $P(Y,"^",2)]"" S (RAPNM,RANM)=$P(Y,"^",2) M RAYY=Y
.I $L($G(Y)) S (RAPNM,RANM)=Y S RAFOUND=1 ; Not found, but something entered, ask if adding new
.;
.I '$D(^RAMIS(71,"B",RANM))!($G(RANEW)&'$G(RAYY)) S RAMV=3 D
.. N Y K DIR S DIR(0)="Y",DIR("A")="Are you adding "_RANM_" as a new Radiology Procedure",DIR("B")="YES" D ^DIR
.. I $G(Y)=1 S RANEW=1 Q
.. I $G(Y)'=1 S RAMV=2,RANEW=0,RAEND=2
;
S RANHIT=1 ; Flag to indicate at least one procedure was entered; ensure validity checker is run before exiting option
I ('$G(RANEW)&($G(RAEND)=2))!($G(RAEND)=1) D END Q
I $G(RAEND)=1!$G(RANQUIT) D END Q
TEMP ;ENTER THE TEMPORARY NEW PROCEDURE INTO 71.11
I '$G(RANEW) G:$L(RANM) OLD G:'$L(RANM) END
G:$G(RAEND) END
; create DA in temp file
K DD,DO,DIC,X,Y S DIC="^RAMRPF(71.11,",DIC(0)="L",X=RANM D FILE^DICN
I +Y<1 W !!,"Not able to create entry in temporary area" G END
S (RADA,RA7111DA)=+Y K ^TMP("RA7111DA",$J) S ^TMP("RA7111DA",$J)=RA7111DA K DIC,X,Y
; do check of name and procedure type"
S DIE="^RAMRPF(71.11,",DA=RA7111DA,DR="6" D ^DIE
; If Category was bypassed by entering "^", remove temp entry and quit
I $P($G(^RAMRPF(71.11,RADA,0)),"^",6)="" W !,"Nothing Saved" G TD
S RACTIVE=$P($G(^RAMPRF(71.11,RADA,"I")),"^"),RASTAT=$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
D TRKCMB^RAMAINU(DA,.RATRKCMB) ;tracks existing
; CM definition before editing. RATRKCMB ids the before CM values
;
S DIE="^RAMRPF(71.11,",DR="[NEW RAD PROCEDURE]",DA=RA7111DA D ^DIE
I $G(Y)="^" W !,"Nothing Saved" G TD
S RADA=DA,RACPT=$P(^RAMRPF(71.11,DA,0),U,9)
I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J))
I $P(^RAMRPF(71.11,RA7111DA,0),U,6)'="D" D
. W !!,"This procedure was not created as a DETAILED exam and will not be matched",!,"to the MASTER RADIOLOGY PROCEDURE FILE." H 2
. Q
I $G(RACPT)'="",$P(^RAMRPF(71.11,RA7111DA,0),U,6)="D" I $G(RANEW)=1 D EN^RANPRO4(RADA) G:$G(RANQUIT)=1 TD
I $P($G(^RAMRPF(71.11,RA7111DA,0)),U,9)="",$P($G(^RAMRPF(71.11,RA7111DA,0)),U,6)="D" W !!,"No CPT Code has been entered. This new procedure will be deleted.",*7 G TD
S RADA=RA7111DA,RAPROC(0)=$G(^RAMRPF(71.11,RADA,0))
S RACTIVE=$P($G(^RAMPRF(71.11,RADA,"I")),"^"),$P(RASTAT,"^",2)=$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
;
I RAPROC(0)]"",("^B^P^"'[(U_$P(RAPROC(0),"^",6)_U)),('+$P(RAPROC(0),"^",9)) D G TD
. W !?5,$C(7),"Procedure Type: ",$S($P(RAPROC(0),"^",6)="S":"SERIES",1:"DETAILED")," ...no CPT code entered..."
. W !?5,"...will delete the record at this time.",!
;
MV ;MOVE TEMPORARY ENTRY TO PERMANENT ENTRY
; changes for RA*5.0*138
;S RAP3=$P(^RAMIS(71,0),U,3)+1
I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J))
;S $P(^RAMIS(71,0),U,3)=RAP3
;S (RADA,RADANEW1)=RAP3
;get 71.11 data
K ARY D GETS^DIQ(71.11,RA7111DA_",","**","I","ARY") S AA=RA7111DA_","
;
; use DICN to get next file 71 entry
K DIC S DIC="^RAMIS(71,",DA="",X=ARY(71.11,AA,.01,"I"),DIC(0)="L",Y="" I X'="" D FILE^DICN
S DA=+Y I DA<1 W !,"Not Able to Create File 71 entry" G TD
S (RADA,RAP3,RADANEW1)=DA
;
; place temp file (71.11) data into Procedure file (71)
;
S AA=RA7111DA_","
K DR S DA=+RADA,DR=".01///"_ARY(71.11,AA,.01,"I"),DIE="^RAMIS(71," D ^DIE
;
K DR S DIE="^RAMIS(71,",DR="",DA=+RADA F I=2,3,4,5,6,7,9,11,12,13,17,18,19,20 I $G(ARY(71.11,AA,I,"I"))'="" S:DR'="" DR=DR_";" S DR=DR_I_"///"_$G(ARY(71.11,AA,I,"I"))
D ^DIE
K DR S DR="",DA=+RADA F I=100,900,901,902,903 I $G(ARY(71.11,AA,I,"I"))'="" S:DR'="" DR=DR_";" S DR=DR_I_"///"_$G(ARY(71.11,AA,I,"I"))
D ^DIE
; education description
K DR S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""EDU"",",B=0 F S B=$O(ARY(71.11,AA,500,B)) Q:'B D
. S C=ARY(71.11,AA,500,B),DA=0,X=C K DIC,DD,DO S DIC=RALRDA,DIC(0)="L" I X'="" D FILE^DICN
; synonym
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",1," I $D(ARY(71.111)) D
. K EE M EE(71.111)=ARY(71.111)
. S B="EE(71.111",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="QEAL",X=C I X'="" D FILE^DICN
; descendents
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",4," I $D(ARY(71.1105)) D
. K EE M EE(71.1105)=ARY(71.1105)
. S B="EE(71.1105",A=B_")"
. F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D
. . . S DIE=RALRDA,DR=""
. . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")"
. . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F
. . . I DR'="" D ^DIE
; message
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",3," I $D(ARY(71.12)) D
. K EE M EE(71.12)=ARY(71.12)
. S B="EE(71.12",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN
; film type
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""F""," I $D(ARY(71.1102)) D
. K EE M EE(71.1102)=ARY(71.1102)
. S B="EE(71.1102",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN
; amis code
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",2," I $D(ARY(71.1103)) D
. K EE M EE(71.1103)=ARY(71.1103)
. S B="EE(71.1103",A=B_")"
. F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D
. . . S DIE=RALRDA,DR=""
. . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")"
. . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F
. . . I DR'="" D ^DIE
; contrast media
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""CM""," I $D(ARY(71.11125)) D
. K EE M EE(71.11125)=ARY(71.11125)
. S B="EE(71.11125",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN
; default cpt modifiers
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""DCM""," I $D(ARY(71.11135)) D
. K EE M EE(71.11135)=ARY(71.11135)
. S B="EE(71.11135",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN
; default medications
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""P""," I $D(ARY(71.1155)) D
. K EE M EE(71.1155)=ARY(71.1155)
. S B="EE(71.1155",A=B_")"
. F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D
. . . S DIE=RALRDA,DR=""
. . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")"
. . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F
. . . I DR'="" D ^DIE
; default radiopharmaceuticals
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""NUC""," I $D(ARY(71.1108)) D
. K EE M EE(71.1108)=ARY(71.1108)
. S B="EE(71.1108",A=B_")"
. F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A I $QS(A,3)=".01" D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN Q:+Y<1 S DA=+Y D
. . . S DIE=RALRDA,DR=""
. . . S D=B_","_$C(34)_$QS(A,2)_$C(34),E=D_")"
. . . F S E=$Q(@E) Q:$E(E,1,$L(D))'=D S F=@E S:DR'="" DR=DR_";" S DR=DR_$QS(E,3)_"///"_F
. . . I DR'="" D ^DIE
; modality
S DA(1)=RADA,RALRDA="^RAMIS(71,"_DA(1)_",""MDL""," I $D(ARY(71.11731)) D
. K EE M EE(71.11731)=ARY(71.11731)
. S B="EE(71.11731",A=B_")" F S A=$Q(@A) Q:$E(A,1,$L(B))'=B S C=@A D
. . K DIC,DD,DO S DA=0,DIC=RALRDA,DIC(0)="L",X=C I X'="" D FILE^DICN
;
S (RADA,RADANEW1)=RAP3
W !!,"Temporary new procedure entry has been moved to the permanent ",!,"RAD/NUC MED PROCEDURE file." H 1
; make sure indexes are set up.
K DA,DIK S DIK="^RAMIS(71,",DA=RADA D IX^DIK K DA,DIK ; populate indexes for (newly created procedure.
;
;tracking items
S RAPROC(0)=$G(^RAMIS(71,RADA,0))
;check for data consistency between the 'CONTRAST MEDIA USED' &
;'CONTRAST MEDIA' fields.
D CMINTEG^RAMAINU1(RADA,RAPROC(0))
D TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
I $O(^RAMIS(71,RADA,"NUC",0)),($P(RAPROC(0),"^",2)=1) D DELRADE(RADA)
S RACTIVE=$P($G(^RAMIS(71,RADA,"I")),"^"),RASTAT=RASTAT_"^"_$S(RACTIVE="":1,RACTIVE>DT:1,1:0)
;if an active parent w/o descendants, inactivate the parent
I $P(RASTAT,U,2),($P(RAPROC(0),U,6)="P"),('$O(^RAMIS(71,RADA,4,0))) D
. K D,D0,D1,DA,DI,DIC,DIE,DQ,DR
. W !!?5,"Inactivating this parent procedure - no descendents.",!,$C(7)
. S DA=RADA,DIE="^RAMIS(71,",DR="100///"_$S($D(DT):DT,1:$$DT^XLFDT())
. D ^DIE K D,D0,D1,DA,DI,DIC,DIE,DQ,DR S $P(RASTAT,U,2)=0 ;inactive
I $P($G(^RA(79.2,+$P(RAPROC(0),U,12),0)),U,5)="Y",(+$O(^RAMIS(71,RADA,"NUC",0))) D VRDIO(RADA)
I "^B^P^"[(U_$P(RAPROC(0),U,6)_U),($P(RAPROC(0),U,9)]"") D
. K %,D,D0,DA,DE,DIC,DIE,DQ,DR
. S DA=RADA,DIE="^RAMIS(71,",DR="9///@" D ^DIE
. W !!?5,"...CPT code deleted because "_$S($P(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$C(7)
. Q
;
ORDITM ;ORDERABLE ITEM ENTRY
W !,"Updating ORDERABLE ITEMS file" ;S RAMSG=RADA,RAMLNB=""
;S ZTREQ="@"
K RADA,RAINADT,RASTAT,RAFILE,RAY,RAENALL
; update orderable file for newly created procedure
S RADA=RADANEW1,RAINADT=$P($G(^RAMIS(71,RADA,"I")),"^")
S RASTAT="1^"_$S(RAINADT="":1,RAINADT>DT:1,1:0)
;S RASTAT="1^1"
S RAENALL=0,RAY=RADA,RAFILE=71
S $P(RAY,"^",2)=$P($G(^RAMIS(71,RADA,0)),"^",1)
D:$$ORQUIK^RAORDU()=1 PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
;D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
I $G(RANMSG)=1 D MSGRAN^RANPRO4(RADA)
K RADA,RAINADT,RASTAT,RAFILE,RAY,RAENALL
;
TD ;DELETE THE TEMPORARY FILE ENTRY
W !,"Deleting temporary entry in file 71.11"
I $G(RA7111DA)="" S RA7111DA=$G(^TMP("RA7111DA",$J))
I RA7111DA>0 D
. K DIK S DIK="^RAMRPF(71.11,",DA=RA7111DA D ^DIK K DIK
. K ^RAMRPF(71.11,"CREAT",DT,DA)
K ^TMP("RA7111DA",$J)
;
;D 22^RAMAIN2
;
END ;ROUTINE END
K RACPT,RADA,RANM,RAPNM,RASEED,RATYP,RAX,RAYY,X,Y,RAMV,RACODE,RANEW,RAP3,RATYPE,I,RA7111DA
K RANEW71,ARY,A,B,C,D,E,F,RALRDA,RACMDIFF,RACTIVE,RAENALL,RAFILE,RAY,RAPROC,RASTAT,RATRKCMA,RAXTMPNM
K DD,DA,DO,DIC,DIR,DR,RAEND,RACODE1,RAOLDIEN,DIE,RANMSG,RATRKCMB,RADANEW1,RAFOUND,AA,EE
K DIK,XX,RADUZ,RAFN,RAINADT,RAS,XMDUN,DTOUT,DUOUT
K ^XTMP("RAMAIN4",$J)
Q
;
OLD ;EXISTING PROCEDUREX ^%
S RANEW=0 ; Make absolutely sure recursive deadlock doesn't occur - 21^RAMAIN2 calls EN^RANPRO.
I $G(RAYY) S (RADA,DA)=+RAYY
I '$G(RAYY) S DIC="^RAMIS(71,",X=RANM D ^DIC S (RADA,DA)=+Y,RAYY=Y
D 21^RAMAIN2
G END
;
VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha-
; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult
; Dose' & 'High Adult Dose' range. This subroutine will display the
; Radiopharmaceutical in question along with the values in question if
; inconsistencies are found.
;
; Input Variable: 'RADA' the ien of the Procedure
N RANUC S RADA(1)=RADA,RADA=0 D EN^DDIOL("","","!")
F S RADA=$O(^RAMIS(71,RADA(1),"NUC",RADA)) Q:RADA'>0 D
. S RANUC(0)=$G(^RAMIS(71,RADA(1),"NUC",RADA,0))
. Q:$P(RANUC(0),"^",2)="" ; no need to validate, nothing input
. I '$$USUAL^RADD2(.RADA,$P(RANUC(0),"^",2)) D
.. N RARRY S RARRY(1)="For Radiopharmaceutical: "
.. S RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$P(RANUC(0),"^"),.01)_$C(7)
.. S RARRY(2)="" D EN^DDIOL(.RARRY,"")
.. Q
. Q
S RADA=RADA(1) K RADA(1)
Q
;
DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple
N RADA1 S RADA1=0
W !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
F S RADA1=$O(^RAMIS(71,RADA,"NUC",RADA1)) Q:RADA1'>0 D
. K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
. S DA(1)=RADA,DA=RADA1,DIE="^RAMIS(71,"_RADA_",""NUC"","
. S DR=".01///@" D ^DIE
. Q
K %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
Q
;
SEARCH(RAINPUT,RAOUTPUT) ; Search file 71 for RAINPUT
; INPUT : RAINPUT = Input value to use in search of file 71
; OUTPUT : RAOUTPUT = Y array, from ^DIC, of entry selected from file 71
;
I $G(RAINPUT)="" D END Q
N RAFILE,X,Y,DD,DIC,DINUM,DLAYGO,DO,RAY,DTOUT,DUOUT
S (RAENALL,RANEW71)=0
S (X,RAOUTPUT)=$G(RAINPUT)
S DIC="^RAMIS(71,",DIC(0)="MEZ"
W ! D ^DIC
; To replicate legacy lookup, if no entry returned from DIC call:
; 1) If exact or partial match of RAINPUT in ^RAMIS(71,"B", return nothing. Calling routine should re-prompt for procedure.
; 2) If NO exact or partial match of RAINPUT in ^RAMIS(71, return output=RAINPUT, calling routine should prompt to add new.
I Y=-1!$G(DUOUT)!$G(DTOUT) D Q
. I $L($G(RAINPUT)) D Q:Y=""
.. I $D(^RAMIS(71,"B",RAINPUT))!($E($O(^RAMIS(71,"B",RAINPUT)),1,$L(RAINPUT))=RAINPUT)!($G(X)="?") S (RAOUTPUT,Y)="" ; Nothing selected
.. I $L($G(X))<3 S (RAOUTPUT,Y)=""
. S RAINPUT=$TR($G(RAINPUT),"""","") S (RAOUTPUT,Y)=RAINPUT S (RANEW71,RANEW)=1
; Exact match found (no user interaction), or selected (user interaction)
I +$G(Y)>0 S RAY=+Y
I $G(RAY) S (DA)=+Y,RAFILE=71 I DA M RAOUTPUT=Y L +^RAMIS(RAFILE,DA):5 I '$T D Q
. W !?5,"This record is currently being edited by another user."
. W !?5,"Try again later!",$C(7)
. K RAOUTPUT S RAOUTPUT=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRANPRO 14450 printed Apr 09, 2024@21:42:18 Page 2
RANPRO ;BPFO/CLT - NEW RADIOLOGY PROCEDURE ; 27 Oct 2016 4:57 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**127,138,150**;Mar 16, 1998;Build 2
+2 ;
+3 ; RA*5*150 INC1933636 Do not allow entry of a semi-colon (;)
EN ; Main entry point - driver for PROCEDURE prompt loop
+1 ;
+2 NEW RANQUIT,RANHIT,RADIO,RAMIS,RAPTY,RAIMAG,RA65,RARMPF,RAEXC
+3 SET RANQUIT=0
SET RANHIT=0
+4 FOR
if $GET(RANQUIT)
QUIT
DO EN2
+5 IF $GET(RANHIT)
DO 22^RAMAIN2
+6 QUIT
+7 ;
EN2 ; Loop entry point for PROCEDURE prompt
+1 NEW RACPT,RADA,RANM,RAPNM,RASEED,RATYP,RAX,RAYY,X,Y,RAMV,RACODE,RANEW,RAP3,RATYPE,I,RA7111DA
+2 NEW RANEW71,ARY,A,B,C,D,E,F,RALRDA,RACMDIFF,RACTIVE,RAENALL,RAFILE,RAY,RAPROC,RASTAT,RATRKCMA,RAXTMPNM
+3 NEW DD,DA,DO,DIC,DIR,DR,RAEND,RACODE1,RAOLDIEN,DIE,RANMSG,RATRKCMB,RADANEW1,RAFOUND,AA,EE
+4 NEW DIK,XX,RADUZ,RAFN,RAINADT,RAS,XMDUN,DTOUT,DUOUT
+5 SET RANQUIT=""
SET RANMSG=""
SET RAMV=0
+6 KILL ^XTMP("RAMAIN4",$JOB)
+7 SET (RANEW,RANEW71,RANQUIT)=0
+8 FOR
Begin DoDot:1
+9 KILL X,Y,RAEND,DIR
+10 SET DIR(0)="FUO^1:60"
SET DIR("A",1)=" "
SET DIR("A")="RAD/NUC MED PROCEDURE NAME"
+11 SET DIR("PRE")="S:$D(X) X=$$UP^XLFSTR(X) K:$L(X)>60 X S:$G(X)[""?"" X=-99"
+12 DO ^DIR
if Y=-99
SET (X,Y)="?"
SET RANM=Y
IF X=""!(X["^")
SET RANQUIT=1
QUIT
+13 ; RA*5*150 Added the next line
+14 IF X[";"
DO EN^DDIOL("Entry must not contain a semi-colon ';' ",,"!?12,$C(7)")
QUIT
+15 SET RAPNM=RANM
+16 KILL Y
DO SEARCH(RAPNM,.Y)
+17 if (Y="")!(Y<0)!(Y="?")
QUIT
+18 SET (RAPNM,RANM)=Y
+19 ; Match found
IF $GET(Y)>0&$LENGTH($PIECE(Y,"^",2))
SET RAFOUND=1
Begin DoDot:2
+20 IF $PIECE(Y,"^",2)]""
SET (RAPNM,RANM)=$PIECE(Y,"^",2)
MERGE RAYY=Y
End DoDot:2
QUIT
+21 ; Not found, but something entered, ask if adding new
IF $LENGTH($GET(Y))
SET (RAPNM,RANM)=Y
SET RAFOUND=1
+22 ;
+23 IF '$DATA(^RAMIS(71,"B",RANM))!($GET(RANEW)&'$GET(RAYY))
SET RAMV=3
Begin DoDot:2
+24 NEW Y
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Are you adding "_RANM_" as a new Radiology Procedure"
SET DIR("B")="YES"
DO ^DIR
+25 IF $GET(Y)=1
SET RANEW=1
QUIT
+26 IF $GET(Y)'=1
SET RAMV=2
SET RANEW=0
SET RAEND=2
End DoDot:2
End DoDot:1
if $GET(RAFOUND)!$GET(RANQUIT)!$GET(RANEW)
QUIT
+27 ;
+28 ; Flag to indicate at least one procedure was entered; ensure validity checker is run before exiting option
SET RANHIT=1
+29 IF ('$GET(RANEW)&($GET(RAEND)=2))!($GET(RAEND)=1)
DO END
QUIT
+30 IF $GET(RAEND)=1!$GET(RANQUIT)
DO END
QUIT
TEMP ;ENTER THE TEMPORARY NEW PROCEDURE INTO 71.11
+1 IF '$GET(RANEW)
if $LENGTH(RANM)
GOTO OLD
if '$LENGTH(RANM)
GOTO END
+2 if $GET(RAEND)
GOTO END
+3 ; create DA in temp file
+4 KILL DD,DO,DIC,X,Y
SET DIC="^RAMRPF(71.11,"
SET DIC(0)="L"
SET X=RANM
DO FILE^DICN
+5 IF +Y<1
WRITE !!,"Not able to create entry in temporary area"
GOTO END
+6 SET (RADA,RA7111DA)=+Y
KILL ^TMP("RA7111DA",$JOB)
SET ^TMP("RA7111DA",$JOB)=RA7111DA
KILL DIC,X,Y
+7 ; do check of name and procedure type"
+8 SET DIE="^RAMRPF(71.11,"
SET DA=RA7111DA
SET DR="6"
DO ^DIE
+9 ; If Category was bypassed by entering "^", remove temp entry and quit
+10 IF $PIECE($GET(^RAMRPF(71.11,RADA,0)),"^",6)=""
WRITE !,"Nothing Saved"
GOTO TD
+11 SET RACTIVE=$PIECE($GET(^RAMPRF(71.11,RADA,"I")),"^")
SET RASTAT=$SELECT(RACTIVE="":1,RACTIVE>DT:1,1:0)
+12 ;tracks existing
DO TRKCMB^RAMAINU(DA,.RATRKCMB)
+13 ; CM definition before editing. RATRKCMB ids the before CM values
+14 ;
+15 SET DIE="^RAMRPF(71.11,"
SET DR="[NEW RAD PROCEDURE]"
SET DA=RA7111DA
DO ^DIE
+16 IF $GET(Y)="^"
WRITE !,"Nothing Saved"
GOTO TD
+17 SET RADA=DA
SET RACPT=$PIECE(^RAMRPF(71.11,DA,0),U,9)
+18 IF $GET(RA7111DA)=""
SET RA7111DA=$GET(^TMP("RA7111DA",$JOB))
+19 IF $PIECE(^RAMRPF(71.11,RA7111DA,0),U,6)'="D"
Begin DoDot:1
+20 WRITE !!,"This procedure was not created as a DETAILED exam and will not be matched",!,"to the MASTER RADIOLOGY PROCEDURE FILE."
HANG 2
+21 QUIT
End DoDot:1
+22 IF $GET(RACPT)'=""
IF $PIECE(^RAMRPF(71.11,RA7111DA,0),U,6)="D"
IF $GET(RANEW)=1
DO EN^RANPRO4(RADA)
if $GET(RANQUIT)=1
GOTO TD
+23 IF $PIECE($GET(^RAMRPF(71.11,RA7111DA,0)),U,9)=""
IF $PIECE($GET(^RAMRPF(71.11,RA7111DA,0)),U,6)="D"
WRITE !!,"No CPT Code has been entered. This new procedure will be deleted.",*7
GOTO TD
+24 SET RADA=RA7111DA
SET RAPROC(0)=$GET(^RAMRPF(71.11,RADA,0))
+25 SET RACTIVE=$PIECE($GET(^RAMPRF(71.11,RADA,"I")),"^")
SET $PIECE(RASTAT,"^",2)=$SELECT(RACTIVE="":1,RACTIVE>DT:1,1:0)
+26 ;
+27 IF RAPROC(0)]""
IF ("^B^P^"'[(U_$PIECE(RAPROC(0),"^",6)_U))
IF ('+$PIECE(RAPROC(0),"^",9))
Begin DoDot:1
+28 WRITE !?5,$CHAR(7),"Procedure Type: ",$SELECT($PIECE(RAPROC(0),"^",6)="S":"SERIES",1:"DETAILED")," ...no CPT code entered..."
+29 WRITE !?5,"...will delete the record at this time.",!
End DoDot:1
GOTO TD
+30 ;
MV ;MOVE TEMPORARY ENTRY TO PERMANENT ENTRY
+1 ; changes for RA*5.0*138
+2 ;S RAP3=$P(^RAMIS(71,0),U,3)+1
+3 IF $GET(RA7111DA)=""
SET RA7111DA=$GET(^TMP("RA7111DA",$JOB))
+4 ;S $P(^RAMIS(71,0),U,3)=RAP3
+5 ;S (RADA,RADANEW1)=RAP3
+6 ;get 71.11 data
+7 KILL ARY
DO GETS^DIQ(71.11,RA7111DA_",","**","I","ARY")
SET AA=RA7111DA_","
+8 ;
+9 ; use DICN to get next file 71 entry
+10 KILL DIC
SET DIC="^RAMIS(71,"
SET DA=""
SET X=ARY(71.11,AA,.01,"I")
SET DIC(0)="L"
SET Y=""
IF X'=""
DO FILE^DICN
+11 SET DA=+Y
IF DA<1
WRITE !,"Not Able to Create File 71 entry"
GOTO TD
+12 SET (RADA,RAP3,RADANEW1)=DA
+13 ;
+14 ; place temp file (71.11) data into Procedure file (71)
+15 ;
+16 SET AA=RA7111DA_","
+17 KILL DR
SET DA=+RADA
SET DR=".01///"_ARY(71.11,AA,.01,"I")
SET DIE="^RAMIS(71,"
DO ^DIE
+18 ;
+19 KILL DR
SET DIE="^RAMIS(71,"
SET DR=""
SET DA=+RADA
FOR I=2,3,4,5,6,7,9,11,12,13,17,18,19,20
IF $GET(ARY(71.11,AA,I,"I"))'=""
if DR'=""
SET DR=DR_";"
SET DR=DR_I_"///"_$GET(ARY(71.11,AA,I,"I"))
+20 DO ^DIE
+21 KILL DR
SET DR=""
SET DA=+RADA
FOR I=100,900,901,902,903
IF $GET(ARY(71.11,AA,I,"I"))'=""
if DR'=""
SET DR=DR_";"
SET DR=DR_I_"///"_$GET(ARY(71.11,AA,I,"I"))
+22 DO ^DIE
+23 ; education description
+24 KILL DR
SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""EDU"","
SET B=0
FOR
SET B=$ORDER(ARY(71.11,AA,500,B))
if 'B
QUIT
Begin DoDot:1
+25 SET C=ARY(71.11,AA,500,B)
SET DA=0
SET X=C
KILL DIC,DD,DO
SET DIC=RALRDA
SET DIC(0)="L"
IF X'=""
DO FILE^DICN
End DoDot:1
+26 ; synonym
+27 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",1,"
IF $DATA(ARY(71.111))
Begin DoDot:1
+28 KILL EE
MERGE EE(71.111)=ARY(71.111)
+29 SET B="EE(71.111"
SET A=B_")"
FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
Begin DoDot:2
+30 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="QEAL"
SET X=C
IF X'=""
DO FILE^DICN
End DoDot:2
End DoDot:1
+31 ; descendents
+32 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",4,"
IF $DATA(ARY(71.1105))
Begin DoDot:1
+33 KILL EE
MERGE EE(71.1105)=ARY(71.1105)
+34 SET B="EE(71.1105"
SET A=B_")"
+35 FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
IF $QSUBSCRIPT(A,3)=".01"
Begin DoDot:2
+36 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
if +Y<1
QUIT
SET DA=+Y
Begin DoDot:3
+37 SET DIE=RALRDA
SET DR=""
+38 SET D=B_","_$CHAR(34)_$QSUBSCRIPT(A,2)_$CHAR(34)
SET E=D_")"
+39 FOR
SET E=$QUERY(@E)
if $EXTRACT(E,1,$LENGTH(D))'=D
QUIT
SET F=@E
if DR'=""
SET DR=DR_";"
SET DR=DR_$QSUBSCRIPT(E,3)_"///"_F
+40 IF DR'=""
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+41 ; message
+42 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",3,"
IF $DATA(ARY(71.12))
Begin DoDot:1
+43 KILL EE
MERGE EE(71.12)=ARY(71.12)
+44 SET B="EE(71.12"
SET A=B_")"
FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
Begin DoDot:2
+45 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
End DoDot:2
End DoDot:1
+46 ; film type
+47 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""F"","
IF $DATA(ARY(71.1102))
Begin DoDot:1
+48 KILL EE
MERGE EE(71.1102)=ARY(71.1102)
+49 SET B="EE(71.1102"
SET A=B_")"
FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
Begin DoDot:2
+50 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
End DoDot:2
End DoDot:1
+51 ; amis code
+52 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",2,"
IF $DATA(ARY(71.1103))
Begin DoDot:1
+53 KILL EE
MERGE EE(71.1103)=ARY(71.1103)
+54 SET B="EE(71.1103"
SET A=B_")"
+55 FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
IF $QSUBSCRIPT(A,3)=".01"
Begin DoDot:2
+56 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
if +Y<1
QUIT
SET DA=+Y
Begin DoDot:3
+57 SET DIE=RALRDA
SET DR=""
+58 SET D=B_","_$CHAR(34)_$QSUBSCRIPT(A,2)_$CHAR(34)
SET E=D_")"
+59 FOR
SET E=$QUERY(@E)
if $EXTRACT(E,1,$LENGTH(D))'=D
QUIT
SET F=@E
if DR'=""
SET DR=DR_";"
SET DR=DR_$QSUBSCRIPT(E,3)_"///"_F
+60 IF DR'=""
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+61 ; contrast media
+62 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""CM"","
IF $DATA(ARY(71.11125))
Begin DoDot:1
+63 KILL EE
MERGE EE(71.11125)=ARY(71.11125)
+64 SET B="EE(71.11125"
SET A=B_")"
FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
Begin DoDot:2
+65 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
End DoDot:2
End DoDot:1
+66 ; default cpt modifiers
+67 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""DCM"","
IF $DATA(ARY(71.11135))
Begin DoDot:1
+68 KILL EE
MERGE EE(71.11135)=ARY(71.11135)
+69 SET B="EE(71.11135"
SET A=B_")"
FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
Begin DoDot:2
+70 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
End DoDot:2
End DoDot:1
+71 ; default medications
+72 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""P"","
IF $DATA(ARY(71.1155))
Begin DoDot:1
+73 KILL EE
MERGE EE(71.1155)=ARY(71.1155)
+74 SET B="EE(71.1155"
SET A=B_")"
+75 FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
IF $QSUBSCRIPT(A,3)=".01"
Begin DoDot:2
+76 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
if +Y<1
QUIT
SET DA=+Y
Begin DoDot:3
+77 SET DIE=RALRDA
SET DR=""
+78 SET D=B_","_$CHAR(34)_$QSUBSCRIPT(A,2)_$CHAR(34)
SET E=D_")"
+79 FOR
SET E=$QUERY(@E)
if $EXTRACT(E,1,$LENGTH(D))'=D
QUIT
SET F=@E
if DR'=""
SET DR=DR_";"
SET DR=DR_$QSUBSCRIPT(E,3)_"///"_F
+80 IF DR'=""
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+81 ; default radiopharmaceuticals
+82 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""NUC"","
IF $DATA(ARY(71.1108))
Begin DoDot:1
+83 KILL EE
MERGE EE(71.1108)=ARY(71.1108)
+84 SET B="EE(71.1108"
SET A=B_")"
+85 FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
IF $QSUBSCRIPT(A,3)=".01"
Begin DoDot:2
+86 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
if +Y<1
QUIT
SET DA=+Y
Begin DoDot:3
+87 SET DIE=RALRDA
SET DR=""
+88 SET D=B_","_$CHAR(34)_$QSUBSCRIPT(A,2)_$CHAR(34)
SET E=D_")"
+89 FOR
SET E=$QUERY(@E)
if $EXTRACT(E,1,$LENGTH(D))'=D
QUIT
SET F=@E
if DR'=""
SET DR=DR_";"
SET DR=DR_$QSUBSCRIPT(E,3)_"///"_F
+90 IF DR'=""
DO ^DIE
End DoDot:3
End DoDot:2
End DoDot:1
+91 ; modality
+92 SET DA(1)=RADA
SET RALRDA="^RAMIS(71,"_DA(1)_",""MDL"","
IF $DATA(ARY(71.11731))
Begin DoDot:1
+93 KILL EE
MERGE EE(71.11731)=ARY(71.11731)
+94 SET B="EE(71.11731"
SET A=B_")"
FOR
SET A=$QUERY(@A)
if $EXTRACT(A,1,$LENGTH(B))'=B
QUIT
SET C=@A
Begin DoDot:2
+95 KILL DIC,DD,DO
SET DA=0
SET DIC=RALRDA
SET DIC(0)="L"
SET X=C
IF X'=""
DO FILE^DICN
End DoDot:2
End DoDot:1
+96 ;
+97 SET (RADA,RADANEW1)=RAP3
+98 WRITE !!,"Temporary new procedure entry has been moved to the permanent ",!,"RAD/NUC MED PROCEDURE file."
HANG 1
+99 ; make sure indexes are set up.
+100 ; populate indexes for (newly created procedure.
KILL DA,DIK
SET DIK="^RAMIS(71,"
SET DA=RADA
DO IX^DIK
KILL DA,DIK
+101 ;
+102 ;tracking items
+103 SET RAPROC(0)=$GET(^RAMIS(71,RADA,0))
+104 ;check for data consistency between the 'CONTRAST MEDIA USED' &
+105 ;'CONTRAST MEDIA' fields.
+106 DO CMINTEG^RAMAINU1(RADA,RAPROC(0))
+107 DO TRKCMA^RAMAINU(RADA,RATRKCMB,.RATRKCMA,.RACMDIFF)
+108 IF $ORDER(^RAMIS(71,RADA,"NUC",0))
IF ($PIECE(RAPROC(0),"^",2)=1)
DO DELRADE(RADA)
+109 SET RACTIVE=$PIECE($GET(^RAMIS(71,RADA,"I")),"^")
SET RASTAT=RASTAT_"^"_$SELECT(RACTIVE="":1,RACTIVE>DT:1,1:0)
+110 ;if an active parent w/o descendants, inactivate the parent
+111 IF $PIECE(RASTAT,U,2)
IF ($PIECE(RAPROC(0),U,6)="P")
IF ('$ORDER(^RAMIS(71,RADA,4,0)))
Begin DoDot:1
+112 KILL D,D0,D1,DA,DI,DIC,DIE,DQ,DR
+113 WRITE !!?5,"Inactivating this parent procedure - no descendents.",!,$CHAR(7)
+114 SET DA=RADA
SET DIE="^RAMIS(71,"
SET DR="100///"_$SELECT($DATA(DT):DT,1:$$DT^XLFDT())
+115 ;inactive
DO ^DIE
KILL D,D0,D1,DA,DI,DIC,DIE,DQ,DR
SET $PIECE(RASTAT,U,2)=0
End DoDot:1
+116 IF $PIECE($GET(^RA(79.2,+$PIECE(RAPROC(0),U,12),0)),U,5)="Y"
IF (+$ORDER(^RAMIS(71,RADA,"NUC",0)))
DO VRDIO(RADA)
+117 IF "^B^P^"[(U_$PIECE(RAPROC(0),U,6)_U)
IF ($PIECE(RAPROC(0),U,9)]"")
Begin DoDot:1
+118 KILL %,D,D0,DA,DE,DIC,DIE,DQ,DR
+119 SET DA=RADA
SET DIE="^RAMIS(71,"
SET DR="9///@"
DO ^DIE
+120 WRITE !!?5,"...CPT code deleted because "_$SELECT($PIECE(RAPROC(0),U,6)="B":"Broad",1:"Parent")_" procedures",!?5,"should not have CPT codes.",!,$CHAR(7)
+121 QUIT
End DoDot:1
+122 ;
ORDITM ;ORDERABLE ITEM ENTRY
+1 ;S RAMSG=RADA,RAMLNB=""
WRITE !,"Updating ORDERABLE ITEMS file"
+2 ;S ZTREQ="@"
+3 KILL RADA,RAINADT,RASTAT,RAFILE,RAY,RAENALL
+4 ; update orderable file for newly created procedure
+5 SET RADA=RADANEW1
SET RAINADT=$PIECE($GET(^RAMIS(71,RADA,"I")),"^")
+6 SET RASTAT="1^"_$SELECT(RAINADT="":1,RAINADT>DT:1,1:0)
+7 ;S RASTAT="1^1"
+8 SET RAENALL=0
SET RAY=RADA
SET RAFILE=71
+9 SET $PIECE(RAY,"^",2)=$PIECE($GET(^RAMIS(71,RADA,0)),"^",1)
+10 if $$ORQUIK^RAORDU()=1
DO PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
+11 ;D PROC^RAO7MFN(RAENALL,RAFILE,RASTAT,RAY)
+12 IF $GET(RANMSG)=1
DO MSGRAN^RANPRO4(RADA)
+13 KILL RADA,RAINADT,RASTAT,RAFILE,RAY,RAENALL
+14 ;
TD ;DELETE THE TEMPORARY FILE ENTRY
+1 WRITE !,"Deleting temporary entry in file 71.11"
+2 IF $GET(RA7111DA)=""
SET RA7111DA=$GET(^TMP("RA7111DA",$JOB))
+3 IF RA7111DA>0
Begin DoDot:1
+4 KILL DIK
SET DIK="^RAMRPF(71.11,"
SET DA=RA7111DA
DO ^DIK
KILL DIK
+5 KILL ^RAMRPF(71.11,"CREAT",DT,DA)
End DoDot:1
+6 KILL ^TMP("RA7111DA",$JOB)
+7 ;
+8 ;D 22^RAMAIN2
+9 ;
END ;ROUTINE END
+1 KILL RACPT,RADA,RANM,RAPNM,RASEED,RATYP,RAX,RAYY,X,Y,RAMV,RACODE,RANEW,RAP3,RATYPE,I,RA7111DA
+2 KILL RANEW71,ARY,A,B,C,D,E,F,RALRDA,RACMDIFF,RACTIVE,RAENALL,RAFILE,RAY,RAPROC,RASTAT,RATRKCMA,RAXTMPNM
+3 KILL DD,DA,DO,DIC,DIR,DR,RAEND,RACODE1,RAOLDIEN,DIE,RANMSG,RATRKCMB,RADANEW1,RAFOUND,AA,EE
+4 KILL DIK,XX,RADUZ,RAFN,RAINADT,RAS,XMDUN,DTOUT,DUOUT
+5 KILL ^XTMP("RAMAIN4",$JOB)
+6 QUIT
+7 ;
OLD ;EXISTING PROCEDUREX ^%
+1 ; Make absolutely sure recursive deadlock doesn't occur - 21^RAMAIN2 calls EN^RANPRO.
SET RANEW=0
+2 IF $GET(RAYY)
SET (RADA,DA)=+RAYY
+3 IF '$GET(RAYY)
SET DIC="^RAMIS(71,"
SET X=RANM
DO ^DIC
SET (RADA,DA)=+Y
SET RAYY=Y
+4 DO 21^RAMAIN2
+5 GOTO END
+6 ;
VRDIO(RADA) ; Validate the 'Usual Dose' field within the 'Default Radiopha-
+1 ; rmaceuticals' multiple. 'Usual Dose' must fall within the 'Low Adult
+2 ; Dose' & 'High Adult Dose' range. This subroutine will display the
+3 ; Radiopharmaceutical in question along with the values in question if
+4 ; inconsistencies are found.
+5 ;
+6 ; Input Variable: 'RADA' the ien of the Procedure
+7 NEW RANUC
SET RADA(1)=RADA
SET RADA=0
DO EN^DDIOL("","","!")
+8 FOR
SET RADA=$ORDER(^RAMIS(71,RADA(1),"NUC",RADA))
if RADA'>0
QUIT
Begin DoDot:1
+9 SET RANUC(0)=$GET(^RAMIS(71,RADA(1),"NUC",RADA,0))
+10 ; no need to validate, nothing input
if $PIECE(RANUC(0),"^",2)=""
QUIT
+11 IF '$$USUAL^RADD2(.RADA,$PIECE(RANUC(0),"^",2))
Begin DoDot:2
+12 NEW RARRY
SET RARRY(1)="For Radiopharmaceutical: "
+13 SET RARRY(1)=RARRY(1)_$$EN1^RAPSAPI(+$PIECE(RANUC(0),"^"),.01)_$CHAR(7)
+14 SET RARRY(2)=""
DO EN^DDIOL(.RARRY,"")
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 SET RADA=RADA(1)
KILL RADA(1)
+18 QUIT
+19 ;
DELRADE(RADA) ; Delete the Default Radiopharmaceuticals multiple
+1 NEW RADA1
SET RADA1=0
+2 WRITE !!?3,"Deleting default radiopharmaceuticals for this procedure...",!
+3 FOR
SET RADA1=$ORDER(^RAMIS(71,RADA,"NUC",RADA1))
if RADA1'>0
QUIT
Begin DoDot:1
+4 KILL %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+5 SET DA(1)=RADA
SET DA=RADA1
SET DIE="^RAMIS(71,"_RADA_",""NUC"","
+6 SET DR=".01///@"
DO ^DIE
+7 QUIT
End DoDot:1
+8 KILL %,%X,%Y,D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+9 QUIT
+10 ;
SEARCH(RAINPUT,RAOUTPUT) ; Search file 71 for RAINPUT
+1 ; INPUT : RAINPUT = Input value to use in search of file 71
+2 ; OUTPUT : RAOUTPUT = Y array, from ^DIC, of entry selected from file 71
+3 ;
+4 IF $GET(RAINPUT)=""
DO END
QUIT
+5 NEW RAFILE,X,Y,DD,DIC,DINUM,DLAYGO,DO,RAY,DTOUT,DUOUT
+6 SET (RAENALL,RANEW71)=0
+7 SET (X,RAOUTPUT)=$GET(RAINPUT)
+8 SET DIC="^RAMIS(71,"
SET DIC(0)="MEZ"
+9 WRITE !
DO ^DIC
+10 ; To replicate legacy lookup, if no entry returned from DIC call:
+11 ; 1) If exact or partial match of RAINPUT in ^RAMIS(71,"B", return nothing. Calling routine should re-prompt for procedure.
+12 ; 2) If NO exact or partial match of RAINPUT in ^RAMIS(71, return output=RAINPUT, calling routine should prompt to add new.
+13 IF Y=-1!$GET(DUOUT)!$GET(DTOUT)
Begin DoDot:1
+14 IF $LENGTH($GET(RAINPUT))
Begin DoDot:2
+15 ; Nothing selected
IF $DATA(^RAMIS(71,"B",RAINPUT))!($EXTRACT($ORDER(^RAMIS(71,"B",RAINPUT)),1,$LENGTH(RAINPUT))=RAINPUT)!($GET(X)="?")
SET (RAOUTPUT,Y)=""
+16 IF $LENGTH($GET(X))<3
SET (RAOUTPUT,Y)=""
End DoDot:2
if Y=""
QUIT
+17 SET RAINPUT=$TRANSLATE($GET(RAINPUT),"""","")
SET (RAOUTPUT,Y)=RAINPUT
SET (RANEW71,RANEW)=1
End DoDot:1
QUIT
+18 ; Exact match found (no user interaction), or selected (user interaction)
+19 IF +$GET(Y)>0
SET RAY=+Y
+20 IF $GET(RAY)
SET (DA)=+Y
SET RAFILE=71
IF DA
MERGE RAOUTPUT=Y
LOCK +^RAMIS(RAFILE,DA):5
IF '$TEST
Begin DoDot:1
+21 WRITE !?5,"This record is currently being edited by another user."
+22 WRITE !?5,"Try again later!",$CHAR(7)
+23 KILL RAOUTPUT
SET RAOUTPUT=""
End DoDot:1
QUIT
+24 QUIT
