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