PSODOSU4 ;BIR/cmf - Dose Check Utility routine continued ;11/18/08
;;7.0;OUTPATIENT PHARMACY;**402,518**;DEC 1997;Build 3
;
;Called from PSODOSUT*. The variable PSODTYPE is expected to be defined.
; PSODTYPE values can be N for dosing for new order, copy, and renews, E for edited and display of individual complex doses, and C for complex orders
;
WRITEXC ;format and write exception messages to the screen
N PSORSNT1,PSORSNT3,PSORSNT4 S PSODLWW=0,DIWL=4,DIWR=76 K ^UTILITY($J,"W")
I PSODLERB["Range Check Error Summary" S PSODLERS=1 I PSODLERZ W:'PSODLQT ! D HD Q:$G(PSODLQTC)
I $G(PSODLERS),$L(PSODLERB)>76&($G(PSOCPXB)>1) S PSODLERB=$E(PSODLERB,14,999),DIWR=76,DIWL=17,DIWF="W" S PSODLERW=1
S X=PSODLERB D:'PSODLQT ^DIWP D HD Q:$G(PSODLQTC)
I '$G(PSODLERW) S (PSODELXF,PSORSNT1,PSORSNT3)=0 F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR D
.S PSORSNT1=PSORSNT1+1 I PSORSNT1=1 D SPAC
.W:PSODELXF&('PSODLQT) ! D HD Q:$G(PSODLQTC) W:'PSODLQT $S(PSORSNT1>1&(PSORSNT3):PSORSNT4,1:" ")_$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) S (PSONFRNF,PSODELXF,PSODLERZ,PSODLEXR,PSOEXCPT)=1
I $G(PSODLERW)&('PSODLQT) D ^DIWW K PSODLERW,PSODLERL S PSODLWW=1 S PSOLASTD(PSOLASTS)=2
K ^UTILITY($J,"W")
Q
;
SPAC ; See if leading spaces need to be added after line 1
N PSORSNT2,PSORSNT5
S PSORSNT2=$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) Q:$E(PSORSNT2)'=" "
F PSORSNT3=1:1:$L(PSORSNT2) I $E(PSORSNT2,PSORSNT3)'=" " Q
S:PSORSNT3'=$L(PSORSNT2) PSORSNT3=PSORSNT3+2 S PSORSNT4="" F PSORSNT5=1:1:PSORSNT3 S PSORSNT4=PSORSNT4_" "
Q
;
HD ;
D HD^PSODOSU2 Q
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODOSU4 1608 printed Dec 13, 2024@02:27:15 Page 2
PSODOSU4 ;BIR/cmf - Dose Check Utility routine continued ;11/18/08
+1 ;;7.0;OUTPATIENT PHARMACY;**402,518**;DEC 1997;Build 3
+2 ;
+3 ;Called from PSODOSUT*. The variable PSODTYPE is expected to be defined.
+4 ; PSODTYPE values can be N for dosing for new order, copy, and renews, E for edited and display of individual complex doses, and C for complex orders
+5 ;
WRITEXC ;format and write exception messages to the screen
+1 NEW PSORSNT1,PSORSNT3,PSORSNT4
SET PSODLWW=0
SET DIWL=4
SET DIWR=76
KILL ^UTILITY($JOB,"W")
+2 IF PSODLERB["Range Check Error Summary"
SET PSODLERS=1
IF PSODLERZ
if 'PSODLQT
WRITE !
DO HD
if $GET(PSODLQTC)
QUIT
+3 IF $GET(PSODLERS)
IF $LENGTH(PSODLERB)>76&($GET(PSOCPXB)>1)
SET PSODLERB=$EXTRACT(PSODLERB,14,999)
SET DIWR=76
SET DIWL=17
SET DIWF="W"
SET PSODLERW=1
+4 SET X=PSODLERB
if 'PSODLQT
DO ^DIWP
DO HD
if $GET(PSODLQTC)
QUIT
+5 IF '$GET(PSODLERW)
SET (PSODELXF,PSORSNT1,PSORSNT3)=0
FOR PSODELXR=0:0
SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
if 'PSODELXR
QUIT
Begin DoDot:1
+6 SET PSORSNT1=PSORSNT1+1
IF PSORSNT1=1
DO SPAC
+7 if PSODELXF&('PSODLQT)
WRITE !
DO HD
if $GET(PSODLQTC)
QUIT
if 'PSODLQT
WRITE $SELECT(PSORSNT1>1&(PSORSNT3):PSORSNT4,1:" ")_$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
SET (PSONFRNF,PSODELXF,PSODLERZ,PSODLEXR,PSOEXCPT)=1
End DoDot:1
+8 IF $GET(PSODLERW)&('PSODLQT)
DO ^DIWW
KILL PSODLERW,PSODLERL
SET PSODLWW=1
SET PSOLASTD(PSOLASTS)=2
+9 KILL ^UTILITY($JOB,"W")
+10 QUIT
+11 ;
SPAC ; See if leading spaces need to be added after line 1
+1 NEW PSORSNT2,PSORSNT5
+2 SET PSORSNT2=$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
if $EXTRACT(PSORSNT2)'=" "
QUIT
+3 FOR PSORSNT3=1:1:$LENGTH(PSORSNT2)
IF $EXTRACT(PSORSNT2,PSORSNT3)'=" "
QUIT
+4 if PSORSNT3'=$LENGTH(PSORSNT2)
SET PSORSNT3=PSORSNT3+2
SET PSORSNT4=""
FOR PSORSNT5=1:1:PSORSNT3
SET PSORSNT4=PSORSNT4_" "
+5 QUIT
+6 ;
HD ;
+1 DO HD^PSODOSU2
QUIT
+2 ;;
