Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAUTL8

RAUTL8.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;Called by File 70, Exam subfile, Procedure Fld 2 Input transform
  1. ;RA*5*45: modified - logic in PRC1, ASK, ASK1, & MES1 subroutines
  1. ; removed - MES subroutine
  1. ;RA*5*72 03/23/2006 BAY/GJC/KAM Remedy Call 136200 Correct UNDEF issue
  1. ;RA*5.0*99 added utility for pt age and pt sex
  1. ;
  1. ;Supported IA #10061 reference to ^VADPT
  1. ;Supported IA #10103 reference to ^XLFDT
  1. ;Supported IA #10142 reference to EN^DDIOL
  1. ;Supported IA #2056 reference to GET1^DIQ and GETS^DIQ
  1. ;Supported IA #10104 reference to UP^XLFSTR
  1. ;Supported IA #10076 reference to ^XUSEC
  1. ;Supported IA #2055 reference to EXTERNAL^DILFD
  1. ;Supported IA #2378 reference to ORCHK^GMRAOR
  1. ;
  1. PRC G PRC1:'$D(^RADPT(DA(2),"DT","AP",X)) ; check for C.M. reaction
  1. N RADUP S RADUP=+$$DPDT^RAUTL8(X,.DA)
  1. I RADUP D ASK Q:'$D(X)
  1. PRC1 ; Check for C.M. reaction on this patient
  1. ; +X is the IEN of the Rad/Nuc Med Procedure in file 71
  1. ; RA*5*72 - Changed next line to preserve variables
  1. N RAGMRAOR S RAGMRAOR=$$GMRAOR(DA(2)) Q:RAGMRAOR'=1
  1. D CONTRAST^RAUTL2(+X) ;displays contrast(s) associated with procedure
  1. ;use RAPMSG for CONTRAST REACTION MESSAGE field 25, file 79
  1. S RAPMSG=$G(^RA(79,+$P(^RADPT(DA(2),"DT",DA(1),0),"^",3),"CON"))
  1. D:RAPMSG'="" EN^DDIOL("..."_RAPMSG_"...","","!?3")
  1. D EN^DDIOL("","","!") ;line feed
  1. K RAPMSG
  1. D:$P($G(^RAMIS(71,+X,0)),U,20)="Y" MES1 ;message only if CM used
  1. Q
  1. ASK ; Prompt user for yes/no response
  1. N RAX D EN^DDIOL("Procedure is already entered for this date. Is it ok to continue? No// ","","!!?3")
  1. ASK1 R RAX:DTIME
  1. S:'$T!(RAX="")!(RAX["^")!("Nn"[$E(RAX)) RAX="N"
  1. K:RAX="N" X Q:'$D(X)
  1. 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
  1. Q
  1. ;
  1. MES1 ; display procedure acceptance message
  1. R !?5,"...Type 'OK' to acknowledge or '^' to select another procedure ==> ",RAX:DTIME
  1. S RAX=$$UP^XLFSTR(RAX)
  1. I '$T!(RAX["^")!(RAX="OK") K:RAX'="OK" X K RAX,RAI Q
  1. G MES1
  1. ;
  1. STATSEL ;Select one or more order statuses
  1. ;INPUT VARIABLES:
  1. ; RANO() array contains status codes prohibited from selection
  1. ;OUTPUT VARIABLES:
  1. ; RAST is a string of status codes selected (ex: 1^3^8)
  1. ; RAORST() is an array of selected status codes and status names
  1. ; (ex: RAORST(1)="DISCONTINUED", RAORST(3)="HOLD", ... )
  1. 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
  1. 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)
  1. STAT W ! K DIR S DIR(0)="L" D ^DIR Q:'$D(Y(0))
  1. S RAST="" F I=1:1 S RASTX=$P(Y(0),",",I) Q:RASTX="" I $D(RAORST(RASTX)) S RAST=RAST_"^"_RASTX
  1. S RAST=$E(RAST,2,99) I RAST="" W !," ?? Sorry, invalid status selection. Please try again.",! G STAT
  1. S I="" F S I=$O(RAORST(I)) Q:I="" I RAST'[I K RAORST(I)
  1. K RASTX,I,X,X1,X2 Q
  1. ;
  1. ;INPUT TRANSFORM FOR SECONDARY INTERPRETING RESIDENT
  1. S() ; do not enter primary OR SAME SEC in secondary interpreting resident
  1. I '$D(X)!('$D(DA(3))) G S2
  1. I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G S2
  1. I $D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SRR","B",+Y)) Q 0 ;SAME SEC RES
  1. I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",12)=+Y Q 0
  1. Q 1
  1. S2 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
  1. I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y)) Q 0 ;SAME SEC RES
  1. I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",12)=+Y Q 0
  1. Q 1
  1. ;INPUT TRANSFORM FOR SECONDARY INTERPRETING STAFF
  1. SSR() ; do not enter primary OR SAME SEC in secondary interpreting staff
  1. I '$D(X)!('$D(DA(3))) G SSR2
  1. I '$D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0)) G SSR2
  1. I $D(^RADPT(DA(3),"DT",DA(2),"P",DA(1),"SSR","B",+Y)) Q 0 ;SAME SEC STF
  1. I $P(^RADPT(DA(3),"DT",DA(2),"P",DA(1),0),"^",15)=+Y Q 0
  1. Q 1
  1. SSR2 I '$D(^RADPT(DA(2),"DT",DA(1),"P",DA,0)) Q 0
  1. I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y)) Q 0 ;SAME SEC STF
  1. I $P(^RADPT(DA(2),"DT",DA(1),"P",DA,0),"^",15)=+Y Q 0
  1. Q 1
  1. ;INPUT TRANSFORM FOR PRIMARY INTERPRETING RESIDENT
  1. ; *** NOT USED - See EN ***
  1. PRRS() ; do not enter secondary into primary interpreting resident screen
  1. ; called from input transform ^DD(70.03,12,0)
  1. I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SRR","B",+Y)) Q 0
  1. Q 1
  1. ;INPUT TRANSFORM FOR PRIMARY INTERPRETING STAFF
  1. ; *** NOT USED - See EN ***
  1. PSRS() ; do not enter secondary into primary interpreting staff screen
  1. ; called from input transform ^DD(70.03,15,0)
  1. I $D(^RADPT(DA(2),"DT",DA(1),"P",DA,"SSR","B",+Y)) Q 0
  1. Q 1
  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
  1. ; the 'Secondary' multiple then delete the 'Secondary' entry.
  1. ; X = 'Primary' IEN, FLD = 'Secondary' mult. to check, RA = DA array
  1. N DA,DEL,HDR,IEN,NODE,SAVEX,SUBDD,XREF
  1. S NODE=$S(FLD=60:"SSR",FLD=70:"SRR",1:""),SAVEX=X
  1. S SUBDD=$S(FLD=60:70.11,FLD=70:70.09,1:""),(IEN,DEL)=0
  1. I (NODE="")!(X'>0)!(FLD'>0)!(SUBDD'>0) Q
  1. F S IEN=$O(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,"B",X,IEN)) Q:IEN'>0 D
  1. . S XREF=0
  1. . F S XREF=$O(^DD(SUBDD,.01,1,XREF)) Q:XREF'>0 D
  1. .. S (D0,DA(3))=RA(2),(D1,DA(2))=RA(1),(D2,DA(1))=RA,(D3,DA)=IEN,X=SAVEX
  1. .. I $G(^DD(SUBDD,.01,1,XREF,2))]"" X ^(2)
  1. .. Q
  1. . K ^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,IEN,0) S DEL=DEL+1
  1. . Q
  1. I DEL D
  1. . S HDR=$G(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0)) Q:HDR=""
  1. . S HDR(3)=+$O(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0))
  1. . S HDR(4)=$P(HDR,U,4)-DEL
  1. . S:HDR(3)'>0 HDR(3)="" S:HDR(4)'>0 HDR(4)=""
  1. . S $P(^RADPT(RA(2),"DT",RA(1),"P",RA,NODE,0),U,3,4)=HDR(3)_U_HDR(4)
  1. . Q
  1. S X=SAVEX
  1. Q
  1. DPDT(RAPRC,RAY) ; Check for registration of duplicate procedures on the same
  1. ; date/time. Called from PRC above.
  1. ; INPUT VARIABLES
  1. ; 'RAPRC' --> IEN of the procedure (71)
  1. ; 'RAY' --> DA array i.e, DA, DA(1), & DA(2)
  1. ; OUTPUT VARIABLES
  1. ; 'RAFLG' --> RAFLG=1 procedure registered for this date/time
  1. ; --> RAFLG=0 initial registration for procedure@date/time
  1. N RA72,RABDT,RACIEN,RAEDT,RAFLG,RAI S RAFLG=0
  1. S RABDT=RAY(1)\1,RAEDT=RABDT_".9999",RAI=RABDT-.0000001
  1. F S RAI=$O(^RADPT(RAY(2),"DT","AP",RAPRC,RAI)) Q:RAI'>0!(RAI>RAEDT) D Q:RAFLG
  1. . Q:RAI=RAY(1) ; At this point our exam status is 'WAITING FOR EXAM'
  1. . S RACIEN=$O(^RADPT(RAY(2),"DT","AP",RAPRC,RAI,0)) Q:'RACIEN
  1. . S RA72=+$P($G(^RADPT(RAY(2),"DT",RAI,"P",RACIEN,0)),U,3) ;xam stat
  1. . S RA72(3)=$P($G(^RA(72,RA72,0)),U,3)
  1. . I RA72(3)'=0 S RAFLG=1 ; cancelled exams are not taken into account
  1. . Q
  1. Q RAFLG
  1. 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
  1. ; an imaging type which match the imaging type of the examination.
  1. ; This screen will also check the classification of the individual to
  1. ; ensure that they are active and valid for the field being edited.
  1. ;
  1. ; Called from DD's: ^DD(70.03,12 - ^DD(70.03,15 - ^DD(70.03,60
  1. ; ^DD(70.03,70 - ^DD(70.09,.01 - ^DD(70.11,.01
  1. ;
  1. ; Input variables: RADA-> DA array, maps to RADFN, RADTI & RACNI
  1. ; RARS-> Classification: Resident("R") or Staff("S")
  1. ; Y-> selected resident/staff
  1. ; RALVL-> "PRI"=Primary physician, "SEC"=Secondary
  1. ;
  1. ; Output variable: $S(1:I-Types & classification match, resident/staff
  1. ; ok,0:no match re-select resident/staff)
  1. ;
  1. 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)))
  1. Q:'$T 0 ; failed the classification part of the screen
  1. Q:$D(^XUSEC("RA ALLOC",+Y)) 1 ; Resident/Staff has access to all loc's!
  1. N RA7002,RACCESS
  1. ; adjust RADA() due Fileman's unpredictable retention of DA() levels
  1. I RALVL="SEC" D
  1. . I '$D(RADA(3)) S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0))
  1. . I $D(RADA(3)),(RADA(2)'=RADA(3)) S RA7002=$G(^RADPT(RADA(3),"DT",RADA(2),0))
  1. . I $D(RADA(3)),(RADA(2)=RADA(3)) S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0))
  1. I RALVL="PRI" S RA7002=$G(^RADPT(RADA(2),"DT",RADA(1),0))
  1. D VARACC^RAUTL6(+Y) ; set-up access array for selected resident/staff
  1. Q:'$D(RACCESS(+Y,"IMG",+$P(RA7002,"^",2))) 0 ; no i-type match
  1. Q 1
  1. ;
  1. 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
  1. ;return: contrast media administered to the patient during an exam
  1. N RAI,RAS S RAI=0,RAS=""
  1. F S RAI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI)) Q:'RAI D
  1. .S RAI(0)=$P($G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"CM",RAI,0)),U)
  1. .S RAS=RAS_$$EXTERNAL^DILFD(70.3225,.01,"",RAI(0))_", "
  1. Q $P(RAS,", ",1,($L(RAS,", ")-1))
  1. ;
  1. GMRAOR(RADA2) ;look for a contrast media reaction
  1. 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
  1. Q $$ORCHK^GMRAOR(RADA2,"CM")
  1. ;
  1. PTAGE(DFN,RADTST) ;return pt age, added by p#99
  1. ;input = DFN pt ien
  1. ; = RADTST date to process pt age from; if blank, use today's date
  1. ;output = pt age
  1. N RADAYS,VADM,VA,VAERR,%,RAYSAVE,RAXSAVE
  1. M RAYSAVE=Y,RAXSAVE=X ;save value of Y and X, patch #90
  1. S:RADTST="" RADTST=$$DT^XLFDT()
  1. D DEM^VADPT ; $P(VADM(3),"^") DOB of patient, internal
  1. S RADAYS=$$FMDIFF^XLFDT(RADTST,$P(VADM(3),"^"),3)
  1. M X=RAXSAVE,Y=RAYSAVE
  1. Q RADAYS\365.25
  1. ;
  1. PTSEX(DFN) ;return pt sex, added by p#99
  1. ;input = pt dfn
  1. ;output = pt sex (M=for MALE, F=for FEMALE)
  1. ;save value of Y and X; patch #90
  1. N VADM,VA,VAERR,%,RAYSAVE,RAXSAVE M RAYSAVE=Y,RAXSAVE=X D DEM^VADPT
  1. M Y=RAYSAVE,X=RAXSAVE
  1. Q $P(VADM(5),U)
  1. PRSCR(RADFN,RADTI,RACNI,RAFRMT) ;return pregnancy screen
  1. ;input: radfn = pt dfn
  1. ; radti = inverse dt
  1. ; racni = ien of exam sub
  1. ; rafrmt = E for External format or I for Internal format
  1. ;return = pregnancy screen
  1. N RAIENS,RAOUT
  1. S RAIENS=RACNI_","_RADTI_","_RADFN_","
  1. D GETS^DIQ(70.03,RAIENS,"32",RAFRMT,"RAOUT")
  1. Q $G(RAOUT(70.03,RAIENS,32,RAFRMT))
  1. PRSCOM(RADFN,RADTI,RACNI) ;return pregnancy screen comment
  1. ;input: radfn = pt dfn
  1. ; radti = inverse dt
  1. ; racni = ien of exam sub
  1. ;return = pregnancy screen comment
  1. N RAIENS,RAOUT
  1. S RAIENS=RACNI_","_RADTI_","_RADFN_","
  1. D GETS^DIQ(70.03,RAIENS,"80","E","RAOUT")
  1. Q $G(RAOUT(70.03,RAIENS,80,"E"))
  1. PRCEXA(RADFN) ;return a previous case exam
  1. ;input: radfn = pt dfn
  1. ;
  1. ;output: racexa(0) =radti^racni, where radti=inverse date ien and racni=record ien
  1. N RADTIEN,RACNIEN
  1. S RADTIEN=$O(^RADPT(RADFN,"DT",0)),RACNIEN=9999,RACNIEN=$O(^RADPT(RADFN,"DT",RADTIEN,"P",RACNIEN),-1)
  1. Q RADTIEN_U_RACNIEN
  1. PRACTO(RADFN) ;returns previous active order IEN of file #75.1 or null if no previous order
  1. ;input radfn = pt dfn
  1. ;output = ien of #75.1
  1. N RA751IEN,RA751PR
  1. S RA751PR=""
  1. S RA751IEN=" " F S RA751IEN=$O(^RAO(75.1,"B",RADFN,RA751IEN),-1) Q:RA751IEN'>0!$G(RA751PR) D
  1. .I $$GET1^DIQ(75.1,RA751IEN,5)="ACTIVE" S RA751PR=RA751IEN
  1. Q RA751PR
  1. PAOE() ;Entry point to enter Pregnancy field of file 75.1. This label is being called from
  1. ;RA ORDER EXAM input template.
  1. ;RETURN value: 0 if unsuccessful (up arrow, timeout or problem occured), 1 if successful.
  1. N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y,X S DIR(0)="75.1,13"
  1. S DIR("B")=$S($G(RAPREG)="y":"YES",$G(RAPREG)="n":"NO",$G(RAPREG)="u":"UNKNOWN",1:"")
  1. S DIR("A")="PREGNANT AT TIME OF ORDER ENTRY" D ^DIR
  1. Q:$D(DIRUT)!$D(DUOUT)!$D(DTOUT)!$D(DIROUT) 0
  1. S RAPREG=$P(Y,"^")
  1. Q 1
  1. ;
  1. 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.
  1. ;
  1. ;Question: "THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
  1. ;If 'Yes' Y=1; if 'No' Y=0
  1. ;The default presented to the user: 'No'
  1. ;
  1. ;Return: the place holder value ('Y' is reset in the RA ORDER EXAM input template)
  1. ;necessary for branching within that template.
  1. ;
  1. N DIR,DTOUT,DUOUT,DIROUT,DIRUT,RAY,X S RAY=Y S DIR(0)="Y",DIR("B")="No"
  1. S DIR("A")="THE SEX OF THIS PATIENT IS NOT AVAILABLE. IS PATIENT FEMALE"
  1. S DIR("?")="Enter 'YES' if patient is female, or 'NO' if patient is male."
  1. D ^DIR
  1. Q $S($D(DIRUT):"@999",Y=0:"@130",1:RAY)
  1. ;
  1. 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
  1. ;input template & the RA REGISTER compiled input template.
  1. ;
  1. ;Input vars
  1. ; RADFN - The DFN of the patient (global)
  1. ; RAQRYST - The value returned by the function: CHKSTAT^RANPROU().
  1. ; Is RAQRYST is zero if study is complete (order #9).
  1. ; Checked in the RA EXAM EDIT input template.
  1. ; Y - The initial place holder value from the RA EXAM EDIT input
  1. ; template.
  1. ;
  1. ;Output var
  1. ; RAY - The place holder variable returned by this function.
  1. ; Either the place holder value is unchanged or is changed
  1. ; if pregnancy is possible or if the study is complete.
  1. ;
  1. ;
  1. ;Return: the place holder value (Y = $$ASKPREG^RAUTL8) necessary for
  1. ;branching within these templates.
  1. ;
  1. ;P137/KLM - Removed report status check. Pregnancy screen will be presented
  1. ;regardless of the report status.
  1. ;
  1. N %,DIERR,RAERR,RAGE,VAERR,X,RAY S RAY=Y
  1. S RAGE=$$PTAGE^RAUTL8(RADFN,"")
  1. I $$PTSEX^RAUTL8(RADFN)'="F"!((RAGE>55)!(RAGE<12)) S RAY="@8001"
  1. S:$G(RAQRYST)=0 RAY="@8001" ;P156/gjc
  1. Q RAY
  1. ;