- RAUTL8 ;HISC/CAH-Utility routines ;14 Mar 2019 4:11 PM
- ;;5.0;Radiology/Nuclear Medicine;**45,72,99,90,137,156**;Mar 16, 1998;Build 1
- ;
- ;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.
- ;
- 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 vars
- ; RADFN - The DFN of the patient (global)
- ; RAQRYST - The value returned by the function: CHKSTAT^RANPROU().
- ; Is RAQRYST is zero if study is complete (order #9).
- ; Checked in the RA EXAM EDIT input template.
- ; Y - The initial place holder value from the RA EXAM EDIT input
- ; template.
- ;
- ;Output var
- ; RAY - The place holder variable returned by this function.
- ; Either the place holder value is unchanged or is changed
- ; if pregnancy is possible or if the study is complete.
- ;
- ;
- ;Return: the place holder value (Y = $$ASKPREG^RAUTL8) necessary for
- ;branching within these templates.
- ;
- ;P137/KLM - Removed report status check. Pregnancy screen will be presented
- ;regardless of the report status.
- ;
- N %,DIERR,RAERR,RAGE,VAERR,X,RAY S RAY=Y
- S RAGE=$$PTAGE^RAUTL8(RADFN,"")
- I $$PTSEX^RAUTL8(RADFN)'="F"!((RAGE>55)!(RAGE<12)) S RAY="@8001"
- S:$G(RAQRYST)=0 RAY="@8001" ;P156/gjc
- Q RAY
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAUTL8 13646 printed Jan 18, 2025@03:41:33 Page 2
- RAUTL8 ;HISC/CAH-Utility routines ;14 Mar 2019 4:11 PM
- +1 ;;5.0;Radiology/Nuclear Medicine;**45,72,99,90,137,156**;Mar 16, 1998;Build 1
- +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 NEW DIR,DTOUT,DUOUT,DIROUT,DIRUT,RAY,X
- SET RAY=Y
- SET DIR(0)="Y"
- SET DIR("B")="No"
- +11 SET DIR("A")="THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
- +12 SET DIR("?")="Enter 'YES' if patient is female, or 'NO' if patient is male."
- +13 DO ^DIR
- +14 QUIT $SELECT($DATA(DIRUT):"@999",Y=0:"@130",1:RAY)
- +15 ;
- 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 vars
- +5 ; RADFN - The DFN of the patient (global)
- +6 ; RAQRYST - The value returned by the function: CHKSTAT^RANPROU().
- +7 ; Is RAQRYST is zero if study is complete (order #9).
- +8 ; Checked in the RA EXAM EDIT input template.
- +9 ; Y - The initial place holder value from the RA EXAM EDIT input
- +10 ; template.
- +11 ;
- +12 ;Output var
- +13 ; RAY - The place holder variable returned by this function.
- +14 ; Either the place holder value is unchanged or is changed
- +15 ; if pregnancy is possible or if the study is complete.
- +16 ;
- +17 ;
- +18 ;Return: the place holder value (Y = $$ASKPREG^RAUTL8) necessary for
- +19 ;branching within these templates.
- +20 ;
- +21 ;P137/KLM - Removed report status check. Pregnancy screen will be presented
- +22 ;regardless of the report status.
- +23 ;
- +24 NEW %,DIERR,RAERR,RAGE,VAERR,X,RAY
- SET RAY=Y
- +25 SET RAGE=$$PTAGE^RAUTL8(RADFN,"")
- +26 IF $$PTSEX^RAUTL8(RADFN)'="F"!((RAGE>55)!(RAGE<12))
- SET RAY="@8001"
- +27 ;P156/gjc
- if $GET(RAQRYST)=0
- SET RAY="@8001"
- +28 QUIT RAY
- +29 ;