- 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 Jan 18, 2025@03:41:29 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 ;