RAUTL8 ;HISC/CAH-Utility routines ; 06 Oct 2013 11:07 AM
;;5.0;Radiology/Nuclear Medicine;**45,72,99,90,1003,1005**;Nov 01, 2010;Build 13
;
;Called by File 70, Exam subfile, Procedure Fld 2 Input transform
;RA*5*45: modified - logic in PRC1, ASK, ASK1, & MES1 subroutines
; removed - MES subroutine
;RA*5*72 03/23/2006 BAY/GJC/KAM Remedy Call 136200 Correct UNDEF issue
;RA*5.0*99 added utility for pt age and pt sex
;
;Supported IA #10061 reference to ^VADPT
;Supported IA #10103 reference to ^XLFDT
;Supported IA #10142 reference to EN^DDIOL
;Supported IA #2056 reference to GET1^DIQ and GETS^DIQ
;Supported IA #10104 reference to UP^XLFSTR
;Supported IA #10076 reference to ^XUSEC
;Supported IA #2055 reference to EXTERNAL^DILFD
;Supported IA #2378 reference to ORCHK^GMRAOR
;
PRC G PRC1:'$D(^RADPT(DA(2),"DT","AP",X)) ; check for C.M. reaction
N RADUP S RADUP=+$$DPDT^RAUTL8(X,.DA)
I RADUP D ASK Q:'$D(X)
PRC1 ; Check for C.M. reaction on this patient
; +X is the IEN of the Rad/Nuc Med Procedure in file 71
; RA*5*72 - Changed next line to preserve variables
N RAGMRAOR S RAGMRAOR=$$GMRAOR(DA(2)) Q:RAGMRAOR'=1
D CONTRAST^RAUTL2(+X) ;displays contrast(s) associated with procedure
;use RAPMSG for CONTRAST REACTION MESSAGE field 25, file 79
S RAPMSG=$G(^RA(79,+$P(^RADPT(DA(2),"DT",DA(1),0),"^",3),"CON"))
D:RAPMSG'="" EN^DDIOL("..."_RAPMSG_"...","","!?3")
D EN^DDIOL("","","!") ;line feed
K RAPMSG
D:$P($G(^RAMIS(71,+X,0)),U,20)="Y" MES1 ;message only if CM used
Q
ASK ; Prompt user for yes/no response
N RAX D EN^DDIOL("Procedure is already entered for this date. Is it ok to continue? No// ","","!!?3")
ASK1 R RAX:DTIME
S:'$T!(RAX="")!(RAX["^")!("Nn"[$E(RAX)) RAX="N"
K:RAX="N" X Q:'$D(X)
I "Yy"'[$E(RAX) S RAPMSG(1)="Enter 'YES' to register patient for this procedure, or 'NO' to edit the",RAPMSG(2)="above procedure. No// ",RAPMSG(1,"F")="!!?3",RAPMSG(2,"F")="!?3" D EN^DDIOL(.RAPMSG) K RAPMSG G ASK1
Q
;
MES1 ; display procedure acceptance message
R !?5,"...Type 'OK' to acknowledge or '^' to select another procedure ==> ",RAX:DTIME
S RAX=$$UP^XLFSTR(RAX)
I '$T!(RAX["^")!(RAX="OK") K:RAX'="OK" X K RAX,RAI Q
G MES1
;
STATSEL ;Select one or more order statuses
;INPUT VARIABLES:
; RANO() array contains status codes prohibited from selection
;OUTPUT VARIABLES:
; RAST is a string of status codes selected (ex: 1^3^8)
; RAORST() is an array of selected status codes and status names
; (ex: RAORST(1)="DISCONTINUED", RAORST(3)="HOLD", ... )
K RAST,RAORST W ! S RAORSTS=$P(^DD(75.1,5,0),U,3) F I=1:1 S X=$P(RAORSTS,";",I) Q:X="" S X1=$P(X,":",1) I '$D(RANO(X1)) S X2=$P(X,":",2),RAORST(X1)=X2
W !!,"Select statuses to include on report.",! S X1="" F S X1=$O(RAORST(X1)) Q:X1="" W !?5,$J(X1,2,0)_" "_RAORST(X1)
STAT W ! K DIR S DIR(0)="L" D ^DIR Q:'$D(Y(0))
S RAST="" F I=1:1 S RASTX=$P(Y(0),",",I) Q:RASTX="" I $D(RAORST(RASTX)) S RAST=RAST_"^"_RASTX
S RAST=$E(RAST,2,99) I RAST="" W !," ?? Sorry, invalid status selection. Please try again.",! G STAT
S I="" F S I=$O(RAORST(I)) Q:I="" I RAST'[I K RAORST(I)
K RASTX,I,X,X1,X2 Q
;
;INPUT TRANSFORM FOR SECONDARY INTERPRETING RESIDENT
S() ; do not enter primary OR SAME SEC in secondary interpreting resident
I '$D(X)!('$D(DA(3))) G S2
I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G S2
I $D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SRR","B",+Y)) Q 0 ;SAME SEC RES
I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",12)=+Y Q 0
Q 1
S2 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y)) Q 0 ;SAME SEC RES
I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",12)=+Y Q 0
Q 1
;INPUT TRANSFORM FOR SECONDARY INTERPRETING STAFF
SSR() ; do not enter primary OR SAME SEC in secondary interpreting staff
I '$D(X)!('$D(DA(3))) G SSR2
I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SSR2
I $D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SSR","B",+Y)) Q 0 ;SAME SEC STF
I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",15)=+Y Q 0
Q 1
SSR2 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y)) Q 0 ;SAME SEC STF
I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",15)=+Y Q 0
Q 1
;INPUT TRANSFORM FOR PRIMARY INTERPRETING RESIDENT
; *** NOT USED - See EN ***
PRRS() ; do not enter secondary into primary interpreting resident screen
; called from input transform ^DD(70.03,12,0)
I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y)) Q 0
Q 1
;INPUT TRANSFORM FOR PRIMARY INTERPRETING STAFF
; *** NOT USED - See EN ***
PSRS() ; do not enter secondary into primary interpreting staff screen
; called from input transform ^DD(70.03,15,0)
I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y)) Q 0
Q 1
EN(X,FLD,RA) ;Input transform screen for Primary Staff, Primary Res
;Used by fields 70.03,12 & 70.03,15. If 'Primary' is found in
; the 'Secondary' multiple then delete the 'Secondary' entry.
; X = 'Primary' IEN, FLD = 'Secondary' mult. to check, RA = DA array
N DA,DEL,HDR,IEN,NODE,SAVEX,SUBDD,XREF
S NODE=$S(FLD=60:"SSR",FLD=70:"SRR",1:""),SAVEX=X
S SUBDD=$S(FLD=60:70.11,FLD=70:70.09,1:""),(IEN,DEL)=0
I (NODE="")!(X'>0)!(FLD'>0)!(SUBDD'>0) Q
F S IEN=$O(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,"B",X,IEN)) Q:IEN'>0 D
. S XREF=0
. F S XREF=$O(^DD(SUBDD,.01,1,XREF)) Q:XREF'>0 D
.. S (D0,DA(3))=RA(2),(D1,DA(2))=RA(1),(D2,DA(1))=RA,(D3,DA)=IEN,X=SAVEX
.. I $G(^DD(SUBDD,.01,1,XREF,2))]"" X ^(2)
.. Q
. K ^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,IEN,0) S DEL=DEL+1
. Q
I DEL D
. S HDR=$G(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0)) Q:HDR=""
. S HDR(3)=+$O(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0))
. S HDR(4)=$P(HDR,U,4)-DEL
. S:HDR(3)'>0 HDR(3)="" S:HDR(4)'>0 HDR(4)=""
. S $P(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0),U,3,4)=HDR(3)_U_HDR(4)
. Q
S X=SAVEX
Q
DPDT(RAPRC,RAY) ; Check for registration of duplicate procedures on the same
; date/time. Called from PRC above.
; INPUT VARIABLES
; 'RAPRC' --> IEN of the procedure (71)
; 'RAY' --> DA array i.e, DA, DA(1), & DA(2)
; OUTPUT VARIABLES
; 'RAFLG' --> RAFLG=1 procedure registered for this date/time
; --> RAFLG=0 initial registration for procedure@date/time
N RA72,RABDT,RACIEN,RAEDT,RAFLG,RAI S RAFLG=0
S RABDT=RAY(1)\1,RAEDT=RABDT_".9999",RAI=RABDT-.0000001
F S RAI=$O(^RADPT(RAY(2),"DT","AP",RAPRC,RAI)) Q:RAI'>0!(RAI>RAEDT) D Q:RAFLG
. Q:RAI=RAY(1) ; At this point our exam status is 'WAITING FOR EXAM'
. S RACIEN=$O(^RADPT(RAY(2),"DT","AP",RAPRC,RAI,0)) Q:'RACIEN
. S RA72=+$P($G(^RADPT(RAY(2),"DT",RAI,"P",RACIEN,0)),U,3) ;xam stat
. S RA72(3)=$P($G(^RA(72,RA72,0)),U,3)
. I RA72(3)'=0 S RAFLG=1 ; cancelled exams are not taken into account
. Q
Q RAFLG
SCRN(RADA,RARS,Y,RALVL) ; check if the primary or secondary int'ng staff
; or resident has access to a location or locations which have
; an imaging type which match the imaging type of the examination.
; This screen will also check the classification of the individual to
; ensure that they are active and valid for the field being edited.
;
; Called from DD's: ^DD(70.03,12 - ^DD(70.03,15 - ^DD(70.03,60
; ^DD(70.03,70 - ^DD(70.09,.01 - ^DD(70.11,.01
;
; Input variables: RADA-> DA array, maps to RADFN, RADTI & RACNI
; RARS-> Classification: Resident("R") or Staff("S")
; Y-> selected resident/staff
; RALVL-> "PRI"=Primary physician, "SEC"=Secondary
;
; Output variable: $S(1:I-Types & classification match, resident/staff
; ok,0:no match re-select resident/staff)
;
I $S('$D(^VA(200,+Y,"RA")):1,'$P(^("RA"),U,3):1,DT'>$P(^("RA"),U,3):1,1:0),($D(^VA(200,"ARC",RARS,+Y)))
Q:'$T 0 ; failed the classification part of the screen
Q:$D(^XUSEC("RA ALLOC",+Y)) 1 ; Resident/Staff has access to all loc's!
N RA7002,RACCESS
; adjust RADA() due Fileman's unpredictable retention of DA() levels
I RALVL="SEC" D
. I '$D(RADA(3)) S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0))
. I $D(RADA(3)),(RADA(2)'=RADA(3)) S RA7002=$G(^RADPT(RADA(3),"DT",RADA(2),0))
. I $D(RADA(3)),(RADA(2)=RADA(3)) S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0))
I RALVL="PRI" S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0))
D VARACC^RAUTL6(+Y) ; set-up access array for selected resident/staff
Q:'$D(RACCESS(+Y,"IMG",+$P(RA7002,"^",2))) 0 ; no i-type match
Q 1
;
CMEDIA(RADFN,RADTI,RACNI) ;return the CM used with an exam
;input: RADFN=patient DFN, RADTI=inv. date/time of exam, RACNI=exam IEN
;return: contrast media administered to the patient during an exam
N RAI,RAS S RAI=0,RAS=""
F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI)) Q:'RAI D
.S RAI(0)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI,0)),U)
.S RAS=RAS_$$EXTERNAL^DILFD(70.3225,.01,"",RAI(0))_", "
Q $P(RAS,", ",1,($L(RAS,", ")-1))
;
GMRAOR(RADA2) ;look for a contrast media reaction
N D,D0,D1,D2,D3,DA,DC,DD,DFN,DG,DH,DI,DIC,DIE,DIEDA,DIEL,DIETMP,DIEXREF,DIFLD,DIIENS,DIOV,DIP,DK,DL,DLAYGO,DM,DN,DOV,DP,DQ,DR,X,Y
Q $$ORCHK^GMRAOR(RADA2,"CM")
;
PTAGE(DFN,RADTST) ;return pt age, added by p#99
;input = DFN pt ien
; = RADTST date to process pt age from; if blank, use today's date
;output = pt age
N RADAYS,VADM,VA,VAERR,%,RAYSAVE,RAXSAVE
M RAYSAVE=Y,RAXSAVE=X ;save value of Y and X, patch #90
S:RADTST="" RADTST=$$DT^XLFDT()
D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal
S RADAYS=$$FMDIFF^XLFDT(RADTST,$P(VADM(3),"^"),3)
M X=RAXSAVE,Y=RAYSAVE
Q RADAYS\365.25
;
PTSEX(DFN) ;return pt sex, added by p#99
;input = pt dfn
;output = pt sex (M=for MALE, F=for FEMALE)
;save value of Y and X; patch #90
N VADM,VA,VAERR,%,RAYSAVE,RAXSAVE M RAYSAVE=Y,RAXSAVE=X D DEM^VADPT
M Y=RAYSAVE,X=RAXSAVE
Q $P(VADM(5),U)
PRSCR(RADFN,RADTI,RACNI,RAFRMT) ;return pregnancy screen
;input: radfn = pt dfn
; radti = inverse dt
; racni = ien of exam sub
; rafrmt = E for External format or I for Internal format
;return = pregnancy screen
N RAIENS,RAOUT
S RAIENS=RACNI_","_RADTI_","_RADFN_","
D GETS^DIQ(70.03,RAIENS,"32",RAFRMT,"RAOUT")
Q $G(RAOUT(70.03,RAIENS,32,RAFRMT))
PRSCOM(RADFN,RADTI,RACNI) ;return pregnancy screen comment
;input: radfn = pt dfn
; radti = inverse dt
; racni = ien of exam sub
;return = pregnancy screen comment
N RAIENS,RAOUT
S RAIENS=RACNI_","_RADTI_","_RADFN_","
D GETS^DIQ(70.03,RAIENS,"80","E","RAOUT")
Q $G(RAOUT(70.03,RAIENS,80,"E"))
PRCEXA(RADFN) ;return a previous case exam
;input: radfn = pt dfn
;
;output: racexa(0) =radti^racni, where radti=inverse date ien and racni=record ien
N RADTIEN,RACNIEN
S RADTIEN=$O(^RADPT(RADFN,"DT",0)),RACNIEN=9999,RACNIEN=$O(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN),-1)
Q RADTIEN_U_RACNIEN
PRACTO(RADFN) ;returns previous active order IEN of file #75.1 or null if no previous order
;input radfn = pt dfn
;output = ien of #75.1
N RA751IEN,RA751PR
S RA751PR=""
S RA751IEN=" " F S RA751IEN=$O(^RAO(75.1,"B",RADFN,RA751IEN),-1) Q:RA751IEN'>0!$G(RA751PR) D
.I $$GET1^DIQ(75.1,RA751IEN,5)="ACTIVE" S RA751PR=RA751IEN
Q RA751PR
PAOE() ;Entry point to enter Pregnancy field of file 75.1. This label is being called from
;RA ORDER EXAM input template.
;RETURN value: 0 if unsuccessful (up arrow, timeout or problem occured), 1 if successful.
N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y,X S DIR(0)="75.1,13"
S DIR("B")=$S($G(RAPREG)="y":"YES",$G(RAPREG)="n":"NO",$G(RAPREG)="u":"UNKNOWN",1:"")
S DIR("A")="PREGNANT AT TIME OF ORDER ENTRY" D ^DIR
Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)!$D(DIROUT) 0
S RAPREG=$P(Y,"^")
Q 1
;
ASKSEX() ;RA*5.0*99 - Determine the sex of the patient by asking the user.
;Called from the RA ORDER EXAM compiled input template.
;
;Question: "THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
;If 'Yes' Y=1; if 'No' Y=0
;The default presented to the user: 'No'
;
;Return: the place holder value ('Y' is reset in the RA ORDER EXAM input template)
;necessary for branching within that template.
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;RA ORDER EXAM already screens out Males, and we want to treat any
;non-males as if they are female, so don't even ask the question
S RAY=Y
Q Y
;
N DIR,DTOUT,DUOUT,DIROUT,DIRUT,RAY,X S RAY=Y S DIR(0)="Y",DIR("B")="No"
S DIR("A")="THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
S DIR("?")="Enter 'YES' if patient is female, or 'NO' if patient is male."
D ^DIR
Q $S($D(DIRUT):"@999",Y=0:"@130",1:RAY)
;
ASKPREG() ;RA*5.0*99 - Evaluate the conditions to present the PREGNANCY
;SCREENING (70.03 ; 32) prompt to the user. Called from the RA EXAM EDIT
;input template & the RA REGISTER compiled input template.
;
;Input: RA0(17) (global) The IEN of the report associated with this exam.
; Note: no IEN will exist when the case is being registered.
; RADFN (global) the IEN of the patient
; Y (global) the place holder for the RA EXAM EDIT input template.
;
;Return: the place holder value (Y = $$ASKPREG^RAUTL8) necessary for
;branching within these templates.
;
N %,DIERR,RAERR,RAGE,RAST,VAERR,X,RAY S RAY=Y
S RAGE=$$PTAGE^RAUTL8(RADFN,""),Y=$G(RA0(17))_","
D:+Y GETS^DIQ(74,Y,5,"I","RAST","RAERR")
S RAST=$G(RAST(74,Y,5,"I"),"")
;
;IHS/BJI/DAY - Patch 1005 - Allow Pregnancy Edit of Verified Reports
;Controlled by a site parameter
I +$G(RAMDIV),$P($G(^RA(79,+RAMDIV,9999999)),U,3)=1,$$PTSEX^RAUTL8(RADFN)'="M",(RAGE<56),(RAGE>11) Q RAY
;End patch
;
;IHS/BJI/DAY - Patch 1005 - Gender Fix
;I $$PTSEX^RAUTL8(RADFN)'="F"!((RAGE>55)!(RAGE<12))!(RAST="V")!(RAST="EF") S RAY="@8001"
I $$PTSEX^RAUTL8(RADFN)="M"!(RAGE>55)!(RAGE<12)!(RAST="V")!(RAST="EF") S RAY="@8001"
;
Q RAY
;
RAUTL8 ;HISC/CAH-Utility routines ; 06 Oct 2013 11:07 AM
+1 ;;5.0;Radiology/Nuclear Medicine;**45,72,99,90,1003,1005**;Nov 01, 2010;Build 13
+2 ;
+3 ;Called by File 70, Exam subfile, Procedure Fld 2 Input transform
+4 ;RA*5*45: modified - logic in PRC1, ASK, ASK1, & MES1 subroutines
+5 ; removed - MES subroutine
+6 ;RA*5*72 03/23/2006 BAY/GJC/KAM Remedy Call 136200 Correct UNDEF issue
+7 ;RA*5.0*99 added utility for pt age and pt sex
+8 ;
+9 ;Supported IA #10061 reference to ^VADPT
+10 ;Supported IA #10103 reference to ^XLFDT
+11 ;Supported IA #10142 reference to EN^DDIOL
+12 ;Supported IA #2056 reference to GET1^DIQ and GETS^DIQ
+13 ;Supported IA #10104 reference to UP^XLFSTR
+14 ;Supported IA #10076 reference to ^XUSEC
+15 ;Supported IA #2055 reference to EXTERNAL^DILFD
+16 ;Supported IA #2378 reference to ORCHK^GMRAOR
+17 ;
PRC ; check for C.M. reaction
IF '$DATA(^RADPT(DA(2),"DT","AP",X))
GOTO PRC1
+1 NEW RADUP
SET RADUP=+$$DPDT^RAUTL8(X,.DA)
+2 IF RADUP
DO ASK
IF '$DATA(X)
QUIT
PRC1 ; Check for C.M. reaction on this patient
+1 ; +X is the IEN of the Rad/Nuc Med Procedure in file 71
+2 ; RA*5*72 - Changed next line to preserve variables
+3 NEW RAGMRAOR
SET RAGMRAOR=$$GMRAOR(DA(2))
IF RAGMRAOR'=1
QUIT
+4 ;displays contrast(s) associated with procedure
DO CONTRAST^RAUTL2(+X)
+5 ;use RAPMSG for CONTRAST REACTION MESSAGE field 25, file 79
+6 SET RAPMSG=$GET(^RA(79,+$PIECE(^RADPT(DA(2),"DT",DA(1),0),"^",3),"CON"))
+7 IF RAPMSG'=""
DO EN^DDIOL("..."_RAPMSG_"...","","!?3")
+8 ;line feed
DO EN^DDIOL("","","!")
+9 KILL RAPMSG
+10 ;message only if CM used
IF $PIECE($GET(^RAMIS(71,+X,0)),U,20)="Y"
DO MES1
+11 QUIT
ASK ; Prompt user for yes/no response
+1 NEW RAX
DO EN^DDIOL("Procedure is already entered for this date. Is it ok to continue? No// ","","!!?3")
ASK1 READ RAX:DTIME
+1 IF '$TEST!(RAX="")!(RAX["^")!("Nn"[$EXTRACT(RAX))
SET RAX="N"
+2 IF RAX="N"
KILL X
IF '$DATA(X)
QUIT
+3 IF "Yy"'[$EXTRACT(RAX)
SET RAPMSG(1)="Enter 'YES' to register patient for this procedure, or 'NO' to edit the"
SET RAPMSG(2)="above procedure. No// "
SET RAPMSG(1,"F")="!!?3"
SET RAPMSG(2,"F")="!?3"
DO EN^DDIOL(.RAPMSG)
KILL RAPMSG
GOTO ASK1
+4 QUIT
+5 ;
MES1 ; display procedure acceptance message
+1 READ !?5,"...Type 'OK' to acknowledge or '^' to select another procedure ==> ",RAX:DTIME
+2 SET RAX=$$UP^XLFSTR(RAX)
+3 IF '$TEST!(RAX["^")!(RAX="OK")
IF RAX'="OK"
KILL X
KILL RAX,RAI
QUIT
+4 GOTO MES1
+5 ;
STATSEL ;Select one or more order statuses
+1 ;INPUT VARIABLES:
+2 ; RANO() array contains status codes prohibited from selection
+3 ;OUTPUT VARIABLES:
+4 ; RAST is a string of status codes selected (ex: 1^3^8)
+5 ; RAORST() is an array of selected status codes and status names
+6 ; (ex: RAORST(1)="DISCONTINUED", RAORST(3)="HOLD", ... )
+7 KILL RAST,RAORST
WRITE !
SET RAORSTS=$PIECE(^DD(75.1,5,0),U,3)
FOR I=1:1
SET X=$PIECE(RAORSTS,";",I)
IF X=""
QUIT
SET X1=$PIECE(X,":",1)
IF '$DATA(RANO(X1))
SET X2=$PIECE(X,":",2)
SET RAORST(X1)=X2
+8 WRITE !!,"Select statuses to include on report.",!
SET X1=""
FOR
SET X1=$ORDER(RAORST(X1))
IF X1=""
QUIT
WRITE !?5,$JUSTIFY(X1,2,0)_" "_RAORST(X1)
STAT WRITE !
KILL DIR
SET DIR(0)="L"
DO ^DIR
IF '$DATA(Y(0))
QUIT
+1 SET RAST=""
FOR I=1:1
SET RASTX=$PIECE(Y(0),",",I)
IF RASTX=""
QUIT
IF $DATA(RAORST(RASTX))
SET RAST=RAST_"^"_RASTX
+2 SET RAST=$EXTRACT(RAST,2,99)
IF RAST=""
WRITE !," ?? Sorry, invalid status selection. Please try again.",!
GOTO STAT
+3 SET I=""
FOR
SET I=$ORDER(RAORST(I))
IF I=""
QUIT
IF RAST'[I
KILL RAORST(I)
+4 KILL RASTX,I,X,X1,X2
QUIT
+5 ;
+6 ;INPUT TRANSFORM FOR SECONDARY INTERPRETING RESIDENT
S() ; do not enter primary OR SAME SEC in secondary interpreting resident
+1 IF '$DATA(X)!('$DATA(DA(3)))
GOTO S2
+2 IF '$DATA(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0))
GOTO S2
+3 ;SAME SEC RES
IF $DATA(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SRR","B",+Y))
QUIT 0
+4 IF $PIECE(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",12)=+Y
QUIT 0
+5 QUIT 1
S2 IF '$DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
QUIT 0
+1 ;SAME SEC RES
IF $DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y))
QUIT 0
+2 IF $PIECE(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",12)=+Y
QUIT 0
+3 QUIT 1
+4 ;INPUT TRANSFORM FOR SECONDARY INTERPRETING STAFF
SSR() ; do not enter primary OR SAME SEC in secondary interpreting staff
+1 IF '$DATA(X)!('$DATA(DA(3)))
GOTO SSR2
+2 IF '$DATA(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0))
GOTO SSR2
+3 ;SAME SEC STF
IF $DATA(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SSR","B",+Y))
QUIT 0
+4 IF $PIECE(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",15)=+Y
QUIT 0
+5 QUIT 1
SSR2 IF '$DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,0))
QUIT 0
+1 ;SAME SEC STF
IF $DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y))
QUIT 0
+2 IF $PIECE(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",15)=+Y
QUIT 0
+3 QUIT 1
+4 ;INPUT TRANSFORM FOR PRIMARY INTERPRETING RESIDENT
+5 ; *** NOT USED - See EN ***
PRRS() ; do not enter secondary into primary interpreting resident screen
+1 ; called from input transform ^DD(70.03,12,0)
+2 IF $DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y))
QUIT 0
+3 QUIT 1
+4 ;INPUT TRANSFORM FOR PRIMARY INTERPRETING STAFF
+5 ; *** NOT USED - See EN ***
PSRS() ; do not enter secondary into primary interpreting staff screen
+1 ; called from input transform ^DD(70.03,15,0)
+2 IF $DATA(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y))
QUIT 0
+3 QUIT 1
EN(X,FLD,RA) ;Input transform screen for Primary Staff, Primary Res
+1 ;Used by fields 70.03,12 & 70.03,15. If 'Primary' is found in
+2 ; the 'Secondary' multiple then delete the 'Secondary' entry.
+3 ; X = 'Primary' IEN, FLD = 'Secondary' mult. to check, RA = DA array
+4 NEW DA,DEL,HDR,IEN,NODE,SAVEX,SUBDD,XREF
+5 SET NODE=$SELECT(FLD=60:"SSR",FLD=70:"SRR",1:"")
SET SAVEX=X
+6 SET SUBDD=$SELECT(FLD=60:70.11,FLD=70:70.09,1:"")
SET (IEN,DEL)=0
+7 IF (NODE="")!(X'>0)!(FLD'>0)!(SUBDD'>0)
QUIT
+8 FOR
SET IEN=$ORDER(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,"B",X,IEN))
IF IEN'>0
QUIT
Begin DoDot:1
+9 SET XREF=0
+10 FOR
SET XREF=$ORDER(^DD(SUBDD,.01,1,XREF))
IF XREF'>0
QUIT
Begin DoDot:2
+11 SET (D0,DA(3))=RA(2)
SET (D1,DA(2))=RA(1)
SET (D2,DA(1))=RA
SET (D3,DA)=IEN
SET X=SAVEX
+12 IF $GET(^DD(SUBDD,.01,1,XREF,2))]""
XECUTE ^(2)
+13 QUIT
End DoDot:2
+14 KILL ^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,IEN,0)
SET DEL=DEL+1
+15 QUIT
End DoDot:1
+16 IF DEL
Begin DoDot:1
+17 SET HDR=$GET(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0))
IF HDR=""
QUIT
+18 SET HDR(3)=+$ORDER(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0))
+19 SET HDR(4)=$PIECE(HDR,U,4)-DEL
+20 IF HDR(3)'>0
SET HDR(3)=""
IF HDR(4)'>0
SET HDR(4)=""
+21 SET $PIECE(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0),U,3,4)=HDR(3)_U_HDR(4)
+22 QUIT
End DoDot:1
+23 SET X=SAVEX
+24 QUIT
DPDT(RAPRC,RAY) ; Check for registration of duplicate procedures on the same
+1 ; date/time. Called from PRC above.
+2 ; INPUT VARIABLES
+3 ; 'RAPRC' --> IEN of the procedure (71)
+4 ; 'RAY' --> DA array i.e, DA, DA(1), & DA(2)
+5 ; OUTPUT VARIABLES
+6 ; 'RAFLG' --> RAFLG=1 procedure registered for this date/time
+7 ; --> RAFLG=0 initial registration for procedure@date/time
+8 NEW RA72,RABDT,RACIEN,RAEDT,RAFLG,RAI
SET RAFLG=0
+9 SET RABDT=RAY(1)\1
SET RAEDT=RABDT_".9999"
SET RAI=RABDT-.0000001
+10 FOR
SET RAI=$ORDER(^RADPT(RAY(2),"DT","AP",RAPRC,RAI))
IF RAI'>0!(RAI>RAEDT)
QUIT
Begin DoDot:1
+11 ; At this point our exam status is 'WAITING FOR EXAM'
IF RAI=RAY(1)
QUIT
+12 SET RACIEN=$ORDER(^RADPT(RAY(2),"DT","AP",RAPRC,RAI,0))
IF 'RACIEN
QUIT
+13 ;xam stat
SET RA72=+$PIECE($GET(^RADPT(RAY(2),"DT",RAI,"P",RACIEN,0)),U,3)
+14 SET RA72(3)=$PIECE($GET(^RA(72,RA72,0)),U,3)
+15 ; cancelled exams are not taken into account
IF RA72(3)'=0
SET RAFLG=1
+16 QUIT
End DoDot:1
IF RAFLG
QUIT
+17 QUIT RAFLG
SCRN(RADA,RARS,Y,RALVL) ; check if the primary or secondary int'ng staff
+1 ; or resident has access to a location or locations which have
+2 ; an imaging type which match the imaging type of the examination.
+3 ; This screen will also check the classification of the individual to
+4 ; ensure that they are active and valid for the field being edited.
+5 ;
+6 ; Called from DD's: ^DD(70.03,12 - ^DD(70.03,15 - ^DD(70.03,60
+7 ; ^DD(70.03,70 - ^DD(70.09,.01 - ^DD(70.11,.01
+8 ;
+9 ; Input variables: RADA-> DA array, maps to RADFN, RADTI & RACNI
+10 ; RARS-> Classification: Resident("R") or Staff("S")
+11 ; Y-> selected resident/staff
+12 ; RALVL-> "PRI"=Primary physician, "SEC"=Secondary
+13 ;
+14 ; Output variable: $S(1:I-Types & classification match, resident/staff
+15 ; ok,0:no match re-select resident/staff)
+16 ;
+17 IF $SELECT('$DATA(^VA(200,+Y,"RA")):1,'$PIECE(^("RA"),U,3):1,DT'>$PIECE(^("RA"),U,3):1,1:0)
IF ($DATA(^VA(200,"ARC",RARS,+Y)))
+18 ; failed the classification part of the screen
IF '$TEST
QUIT 0
+19 ; Resident/Staff has access to all loc's!
IF $DATA(^XUSEC("RA ALLOC",+Y))
QUIT 1
+20 NEW RA7002,RACCESS
+21 ; adjust RADA() due Fileman's unpredictable retention of DA() levels
+22 IF RALVL="SEC"
Begin DoDot:1
+23 IF '$DATA(RADA(3))
SET RA7002=$GET(^RADPT(RADA(2),"DT",RADA(1),0))
+24 IF $DATA(RADA(3))
IF (RADA(2)'=RADA(3))
SET RA7002=$GET(^RADPT(RADA(3),"DT",RADA(2),0))
+25 IF $DATA(RADA(3))
IF (RADA(2)=RADA(3))
SET RA7002=$GET(^RADPT(RADA(2),"DT",RADA(1),0))
End DoDot:1
+26 IF RALVL="PRI"
SET RA7002=$GET(^RADPT(RADA(2),"DT",RADA(1),0))
+27 ; set-up access array for selected resident/staff
DO VARACC^RAUTL6(+Y)
+28 ; no i-type match
IF '$DATA(RACCESS(+Y,"IMG",+$PIECE(RA7002,"^",2)))
QUIT 0
+29 QUIT 1
+30 ;
CMEDIA(RADFN,RADTI,RACNI) ;return the CM used with an exam
+1 ;input: RADFN=patient DFN, RADTI=inv. date/time of exam, RACNI=exam IEN
+2 ;return: contrast media administered to the patient during an exam
+3 NEW RAI,RAS
SET RAI=0
SET RAS=""
+4 FOR
SET RAI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI))
IF 'RAI
QUIT
Begin DoDot:1
+5 SET RAI(0)=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI,0)),U)
+6 SET RAS=RAS_$$EXTERNAL^DILFD(70.3225,.01,"",RAI(0))_", "
End DoDot:1
+7 QUIT $PIECE(RAS,", ",1,($LENGTH(RAS,", ")-1))
+8 ;
GMRAOR(RADA2) ;look for a contrast media reaction
+1 NEW D,D0,D1,D2,D3,DA,DC,DD,DFN,DG,DH,DI,DIC,DIE,DIEDA,DIEL,DIETMP,DIEXREF,DIFLD,DIIENS,DIOV,DIP,DK,DL,DLAYGO,DM,DN,DOV,DP,DQ,DR,X,Y
+2 QUIT $$ORCHK^GMRAOR(RADA2,"CM")
+3 ;
PTAGE(DFN,RADTST) ;return pt age, added by p#99
+1 ;input = DFN pt ien
+2 ; = RADTST date to process pt age from; if blank, use today's date
+3 ;output = pt age
+4 NEW RADAYS,VADM,VA,VAERR,%,RAYSAVE,RAXSAVE
+5 ;save value of Y and X, patch #90
MERGE RAYSAVE=Y,RAXSAVE=X
+6 IF RADTST=""
SET RADTST=$$DT^XLFDT()
+7 ; $P(VADM(3),"^") DOB of patient, internal
DO DEM^VADPT
+8 SET RADAYS=$$FMDIFF^XLFDT(RADTST,$PIECE(VADM(3),"^"),3)
+9 MERGE X=RAXSAVE,Y=RAYSAVE
+10 QUIT RADAYS\365.25
+11 ;
PTSEX(DFN) ;return pt sex, added by p#99
+1 ;input = pt dfn
+2 ;output = pt sex (M=for MALE, F=for FEMALE)
+3 ;save value of Y and X; patch #90
+4 NEW VADM,VA,VAERR,%,RAYSAVE,RAXSAVE
MERGE RAYSAVE=Y,RAXSAVE=X
DO DEM^VADPT
+5 MERGE Y=RAYSAVE,X=RAXSAVE
+6 QUIT $PIECE(VADM(5),U)
PRSCR(RADFN,RADTI,RACNI,RAFRMT) ;return pregnancy screen
+1 ;input: radfn = pt dfn
+2 ; radti = inverse dt
+3 ; racni = ien of exam sub
+4 ; rafrmt = E for External format or I for Internal format
+5 ;return = pregnancy screen
+6 NEW RAIENS,RAOUT
+7 SET RAIENS=RACNI_","_RADTI_","_RADFN_","
+8 DO GETS^DIQ(70.03,RAIENS,"32",RAFRMT,"RAOUT")
+9 QUIT $GET(RAOUT(70.03,RAIENS,32,RAFRMT))
PRSCOM(RADFN,RADTI,RACNI) ;return pregnancy screen comment
+1 ;input: radfn = pt dfn
+2 ; radti = inverse dt
+3 ; racni = ien of exam sub
+4 ;return = pregnancy screen comment
+5 NEW RAIENS,RAOUT
+6 SET RAIENS=RACNI_","_RADTI_","_RADFN_","
+7 DO GETS^DIQ(70.03,RAIENS,"80","E","RAOUT")
+8 QUIT $GET(RAOUT(70.03,RAIENS,80,"E"))
PRCEXA(RADFN) ;return a previous case exam
+1 ;input: radfn = pt dfn
+2 ;
+3 ;output: racexa(0) =radti^racni, where radti=inverse date ien and racni=record ien
+4 NEW RADTIEN,RACNIEN
+5 SET RADTIEN=$ORDER(^RADPT(RADFN,"DT",0))
SET RACNIEN=9999
SET RACNIEN=$ORDER(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN),-1)
+6 QUIT RADTIEN_U_RACNIEN
PRACTO(RADFN) ;returns previous active order IEN of file #75.1 or null if no previous order
+1 ;input radfn = pt dfn
+2 ;output = ien of #75.1
+3 NEW RA751IEN,RA751PR
+4 SET RA751PR=""
+5 SET RA751IEN=" "
FOR
SET RA751IEN=$ORDER(^RAO(75.1,"B",RADFN,RA751IEN),-1)
IF RA751IEN'>0!$GET(RA751PR)
QUIT
Begin DoDot:1
+6 IF $$GET1^DIQ(75.1,RA751IEN,5)="ACTIVE"
SET RA751PR=RA751IEN
End DoDot:1
+7 QUIT RA751PR
PAOE() ;Entry point to enter Pregnancy field of file 75.1. This label is being called from
+1 ;RA ORDER EXAM input template.
+2 ;RETURN value: 0 if unsuccessful (up arrow, timeout or problem occured), 1 if successful.
+3 NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y,X
SET DIR(0)="75.1,13"
+4 SET DIR("B")=$SELECT($GET(RAPREG)="y":"YES",$GET(RAPREG)="n":"NO",$GET(RAPREG)="u":"UNKNOWN",1:"")
+5 SET DIR("A")="PREGNANT AT TIME OF ORDER ENTRY"
DO ^DIR
+6 IF $DATA(DIRUT)!$DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
QUIT 0
+7 SET RAPREG=$PIECE(Y,"^")
+8 QUIT 1
+9 ;
ASKSEX() ;RA*5.0*99 - Determine the sex of the patient by asking the user.
+1 ;Called from the RA ORDER EXAM compiled input template.
+2 ;
+3 ;Question: "THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
+4 ;If 'Yes' Y=1; if 'No' Y=0
+5 ;The default presented to the user: 'No'
+6 ;
+7 ;Return: the place holder value ('Y' is reset in the RA ORDER EXAM input template)
+8 ;necessary for branching within that template.
+9 ;
+10 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+11 ;RA ORDER EXAM already screens out Males, and we want to treat any
+12 ;non-males as if they are female, so don't even ask the question
+13 SET RAY=Y
+14 QUIT Y
+15 ;
+16 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT,RAY,X
SET RAY=Y
SET DIR(0)="Y"
SET DIR("B")="No"
+17 SET DIR("A")="THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
+18 SET DIR("?")="Enter 'YES' if patient is female, or 'NO' if patient is male."
+19 DO ^DIR
+20 QUIT $SELECT($DATA(DIRUT):"@999",Y=0:"@130",1:RAY)
+21 ;
ASKPREG() ;RA*5.0*99 - Evaluate the conditions to present the PREGNANCY
+1 ;SCREENING (70.03 ; 32) prompt to the user. Called from the RA EXAM EDIT
+2 ;input template & the RA REGISTER compiled input template.
+3 ;
+4 ;Input: RA0(17) (global) The IEN of the report associated with this exam.
+5 ; Note: no IEN will exist when the case is being registered.
+6 ; RADFN (global) the IEN of the patient
+7 ; Y (global) the place holder for the RA EXAM EDIT input template.
+8 ;
+9 ;Return: the place holder value (Y = $$ASKPREG^RAUTL8) necessary for
+10 ;branching within these templates.
+11 ;
+12 NEW %,DIERR,RAERR,RAGE,RAST,VAERR,X,RAY
SET RAY=Y
+13 SET RAGE=$$PTAGE^RAUTL8(RADFN,"")
SET Y=$GET(RA0(17))_","
+14 IF +Y
DO GETS^DIQ(74,Y,5,"I","RAST","RAERR")
+15 SET RAST=$GET(RAST(74,Y,5,"I"),"")
+16 ;
+17 ;IHS/BJI/DAY - Patch 1005 - Allow Pregnancy Edit of Verified Reports
+18 ;Controlled by a site parameter
+19 IF +$GET(RAMDIV)
IF $PIECE($GET(^RA(79,+RAMDIV,9999999)),U,3)=1
IF $$PTSEX^RAUTL8(RADFN)'="M"
IF (RAGE<56)
IF (RAGE>11)
QUIT RAY
+20 ;End patch
+21 ;
+22 ;IHS/BJI/DAY - Patch 1005 - Gender Fix
+23 ;I $$PTSEX^RAUTL8(RADFN)'="F"!((RAGE>55)!(RAGE<12))!(RAST="V")!(RAST="EF") S RAY="@8001"
+24 IF $$PTSEX^RAUTL8(RADFN)="M"!(RAGE>55)!(RAGE<12)!(RAST="V")!(RAST="EF")
SET RAY="@8001"
+25 ;
+26 QUIT RAY
+27 ;
