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

RAUTL5.m

Go to the documentation of this file.
  1. RAUTL5 ;HISC/CAH,FPT,GJC-Utility Routine ;3/12/98 13:27
  1. ;;5.0;Radiology/Nuclear Medicine;**8,26,75**;Mar 16, 1998;Build 4
  1. CH ; Populate the 'CLINICAL HISTORY' field (#400); file 75.1 (^RAO(75.1))
  1. ; Called from 'CREATE1^RAORD1'.
  1. ;
  1. ;Ask for 'Reason for Study' (required)
  1. ;Note: RAOUT & RAREAST will be needed later in the ordering process
  1. D STYREA(.RAOUT,.RAREAST) I $D(RAOUT) D XIT QUIT
  1. K ^TMP($J,"RAWP") ;must always start with a clean slate...
  1. ;
  1. CH1 ;ask/re-ask 'CLINICAL HISTORY'
  1. I $D(RAVSTFLG),$D(RAVLEDTI),$D(RAVLECNI),$D(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,"H")) S:$D(^("H",0)) ^TMP($J,"RAWP",0)=^(0) F RAI=1:1 Q:'$D(^RADPT(RADFN,"DT",RAVLEDTI,"P",RAVLECNI,"H",RAI,0)) S ^TMP($J,"RAWP",RAI,0)=^(0)
  1. ;Display the Rad/Nuc Med division specific clin. history message (in any)
  1. I $L($G(^RA(79,+RADIV,"HIS"))) W !!?3,$C(7),^("HIS"),! K DIR S DIR(0)="E" D ^DIR
  1. I $D(DIRUT) D XIT Q
  1. N RAYN S DIC="^TMP("_$J_",""RAWP"",",DWPK=1,DIWESUB="Clinical History"
  1. W !,"CLINICAL HISTORY FOR EXAM" D EN^DIWE K DIC,DIWESUB,DWPK
  1. I '$O(^TMP($J,"RAWP",0)) D XIT QUIT
  1. K DIC S DIC="^TMP("_$J_",""RAWP"",",DWPK=1
  1. S RAWPFLG=$$VALWP("^TMP("_$J_",""RAWP"","),RAYN=0
  1. I 'RAWPFLG D D:RAYN'=1 PURGECH Q:RAYN'=1 G CH1
  1. .W !!,$C(7),"Text must be at least two (2) alphanumeric characters in length.",!
  1. .N X,Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT S DIR(0)="Y",DIR("B")="Yes"
  1. .S DIR("A")="Do you want to enter a proper clinical history for this request"
  1. .S DIR("?",1)="The clinical history must at a minimum consist of two alphanumeric characters."
  1. .S DIR("?",2)="Enter 'Y' to enter a proper clinical history, or 'N' to bypass entering"
  1. .S DIR("?")="the clinical history for this request." D ^DIR
  1. .S:+Y RAYN=1 ;the user will to try to enter a CH
  1. .S:$D(DIRUT)#2 RAYN=-1 ;timeout or caret entered, exit w/o a CH
  1. .;else the user enters 'No' and does not want to enter a CH
  1. .K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. .Q
  1. I RAYN<1 D XIT Q
  1. WPLEN ;Is clin hist too long to go into a local array for OE/RR HL7 msg?
  1. N RACNT,RAX S (RACNT,RAX)=0
  1. F S RAX=$O(^TMP($J,"RAWP",RAX)) S RACNT=RACNT+1 Q:RAX'>0
  1. I RACNT>350 S RAYN=0 D D:RAYN'=1 PURGECH Q:RAYN'=1 G CH1
  1. .W !!,$C(7),"The clinical history cannot exceed 350 lines in length."
  1. .N X,Y K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. .S DIR(0)="Y",DIR("B")="Yes"
  1. .S DIR("A")="Do you want to enter a proper clinical history for this request"
  1. .S DIR("?",1)="The clinical history cannot exceed 350 lines in length and must"
  1. .S DIR("?",2)=" at a minimum consist of two alphanumeric characters."
  1. .S DIR("?",3)="Enter 'Y' to enter a proper clinical history, or 'N' to bypass"
  1. .S DIR("?")="entering the clinical history for this request." D ^DIR
  1. .S:+Y RAYN=1 ;the user will to try to enter a CH
  1. .S:$D(DIRUT)#2 RAYN=-1 ;timeout or caret entered, exit w/o a CH
  1. .;else the user enters 'No' and does not want to enter a CH
  1. .K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. .Q
  1. XIT ;kill variable(s), exit CH subroutine
  1. K RAWPFLG
  1. Q
  1. ;
  1. VALWP(RAROOT) ; Validate word processing field.
  1. ; Pass back '1' if data is valid, '0' if not valid.
  1. ; at least 2 alphanumeric char's required
  1. Q:'$O(@(RAROOT_"0)")) 0
  1. N CHAR,CNT,WL,WPFLG,X,Y,Z
  1. S (WPFLG,X)=0
  1. F S X=$O(@(RAROOT_X_")")) Q:X'>0 D Q:WPFLG
  1. . S (CNT,WL)=0
  1. . S Y=$G(@(RAROOT_X_",0)")) Q:Y']""
  1. . S WL=$L(Y)
  1. . F Z=1:1:WL D Q:WPFLG
  1. .. S CHAR=$E(Y,Z) S:CHAR?1AN CNT=CNT+1
  1. .. S:CHAR'?1AN&(CNT>0) CNT=0 S:CNT=2 WPFLG=1
  1. .. Q
  1. . Q
  1. Q WPFLG
  1. RDQ(D0) ; Used by input transform on ^DD(74.31,2
  1. ; Checks for unprinted reports associated with REPORT
  1. ; DISTRIBUTION QUEUE of internal entry number of D0.
  1. N %,%Y,FOUND,RA744
  1. S (FOUND,RA744)=0
  1. F S RA744=$O(^RABTCH(74.4,"C",D0,RA744)) Q:RA744'>0!FOUND D
  1. . S FOUND=($P($G(^RABTCH(74.4,RA744,0)),"^",4)'>0)
  1. . Q
  1. Q:'FOUND
  1. W !!,"*** UNPRINTED REPORTS IN THE QUEUE ! ***"
  1. W !,"If this queue is inactivated before printing, these reports will be",!,"removed from the queue."
  1. F D Q:%
  1. . W !!,"Are you sure you want to remove these reports"
  1. . S %=2 D YN^DICN
  1. . I '% W !!?5,"Please answer Y(es) or N(o)."
  1. . Q
  1. I %'=1 W !,"Inactivation date deleted" K X
  1. Q
  1. ATND(RADFN,DATE) ;Returns the external form of the ATTENDING PHYSICIAN
  1. ;for patient RADFN (IEN file #2) on date DATE (FM format)
  1. N DPT,VA200,VAIP,X
  1. S DFN=RADFN,VAIP("D")=DATE,VA200=1
  1. I DATE D IN5^VADPT
  1. S X=$P($G(VAIP(18)),"^",2),X=$S(X]"":X,1:"UNKNOWN")
  1. Q X
  1. PRIM(RADFN,DATE) ;Returns the external form of the PRIMARY PHYSICIAN
  1. ;for patient RADFN (IEN file #2) on date DATE (FM format)
  1. N DPT,VA200,VAIP,X
  1. S DFN=RADFN,VAIP("D")=DATE,VA200=1
  1. I DATE D IN5^VADPT
  1. I '+$G(VAIP(7)) D
  1. . ; If the Primary Physician is not found (based on inpatient episode)
  1. . ; find the current PC Practitioner (See patch SD*5.3*30)
  1. . ; VAIP(7) is null at this point. VAIP(7) will exit this DO block
  1. . ; set to the Primary Care Practitioner or null.
  1. . N X S X="SDUTL3" X ^%ZOSF("TEST")
  1. . S:$T VAIP(7)=$$OUTPTPR^SDUTL3(RADFN)
  1. . Q
  1. S X=$P($G(VAIP(7)),"^",2),X=$S(X]"":X,1:"UNKNOWN")
  1. Q X
  1. EOS() ; 'End Of Screen' prompt for terminals only, check user response.
  1. Q:$E(IOST,1,2)'="C-" 0
  1. N RAY,X,X1,X2,X3,Y,Y0,Y1,Y2,Y3,Y4,Y5
  1. ;Returns 1 if user enters anything other than a carriage return
  1. K DIR S DIR(0)="E" D ^DIR K DIR,DIROUT,DIRUT,DTOUT,DUOUT
  1. S RAY='+Y
  1. Q RAY
  1. XTERNAL(Y,C) ; Change internal format to external format
  1. ; 'Y' is the internal form of the data
  1. ; 'C' defines the data type of the variable 'Y'
  1. D:Y]"" Y^DIQ
  1. Q Y
  1. PROCMSG(RAPRI) ; Print the appropriate procedure messages. Called from
  1. ; DESDT^RAUTL12. This code works under the assumption that the
  1. ; user has entered through OE/RR.
  1. ;ATTENTION: this code must be parallet to code in EN2^RAPRI
  1. Q:+$G(RASTOP) ; Do not display if displayed in the past.
  1. I $O(^RAMIS(71,RAPRI,3,0)) D S RASTOP=1
  1. . N I,RAX,X S I=0
  1. . W !!?5,"NOTE: The following special requirements apply to this "
  1. . W "procedure:",$C(7),!
  1. . F S I=+$O(^RAMIS(71,RAPRI,3,I)) Q:'I D
  1. .. S RAX=+$G(^RAMIS(71,RAPRI,3,I,0))
  1. .. I $D(^RAMIS(71.4,+RAX,0)) D
  1. ... I $Y>(IOSL-6) D READ^ORUTL W @IOF
  1. ... S X=$G(^RAMIS(71.4,+RAX,0)) W !?3,X
  1. ... Q
  1. .. Q
  1. . Q
  1. I $O(^RAMIS(71,RAPRI,"EDU",0)),($$UP^XLFSTR($P($G(^RAMIS(71,RAPRI,0)),"^",17))="Y") D
  1. . W:+$O(^RAMIS(71,+RAPRI,3,0))>0 !!
  1. . N DIW,DIWF,DIWL,DIWR,RAX,X
  1. . K ^UTILITY($J,"W") S DIWF="W",DIWL=1,DIWR=75,RAX=0
  1. . F S RAX=$O(^RAMIS(71,RAPRI,"EDU",RAX)) Q:RAX'>0 D
  1. .. I $Y>(IOSL-4) D READ^ORUTL W @IOF
  1. .. S X=$G(^RAMIS(71,RAPRI,"EDU",RAX,0)) D ^DIWP
  1. .. Q
  1. . I $Y>(IOSL-4) D READ^ORUTL W @IOF
  1. . D ^DIWW
  1. . W !
  1. . Q
  1. Q
  1. MIDNGHT(X) ; Check if the date passed in is midnight. If it is, add one
  1. ; minute to the date/time. Fixes infinite loop problem in FM when
  1. ; midnight.
  1. ; Input: X-Current system date/time (derived from $$NOW^XLFDT)
  1. S:X["." X=$E(X,1,($F(X,".")+3)) ; chop off seconds IF there's decimal
  1. S:+$P(X,".",2)=24!(+$P(X,".",2)=0) X=$$FMADD^XLFDT(X,0,0,1,0) ; add a minute to midnight
  1. Q X
  1. ;
  1. STYREA(RAOUT,RAREAST) ;ask for the 'Reason for Study' P75 (required)
  1. ;return: RAOUT-set if the user enters '^' or times out
  1. ; RAREAST-the reason entered by the user
  1. N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y S DIR(0)="75.1,1.1" D ^DIR
  1. S:$D(DIRUT)#2 RAOUT="" Q:$D(RAOUT)#2 S RAREAST=Y
  1. Q
  1. ;
  1. DIWP(DIWL,DIWR,X) ; work ^DIWP & ^DIWW FM call "WRITE" mode P75
  1. ;input: DIWL=left margin
  1. ; DIWR=right margin
  1. ; X=text to be formatted
  1. N %,DIW,DIWF,DIWT,DN,I,Z
  1. K ^UTILITY($J,"W") S DIWF="W" D ^DIWP,^DIWW
  1. K ^UTILITY($J,"W")
  1. Q
  1. ;
  1. PURGECH ;Delete the invalid 'CLINICAL HISTORY'; inform the user
  1. ;of the deletion (user interactive roll & scroll interface).
  1. W !,"Invalid CLINICAL HISTORY deleted..." K ^TMP($J,"RAWP")
  1. Q
  1. ;