- PSODOSU2 ;BIR/RTR - Dose Check Utility routine continued ;11/18/08
- ;;7.0;OUTPATIENT PHARMACY;**251,375,372,436,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
- ;
- EN ;new order, copy, renew, and verify orders
- N PSODLERW,PSODLERL,PSODLERS,PSODLERH,PSOCPXRR,PSODLWW,PSODOSER,PSONFRNF,PSOWMSG,PSODLQTC,PSOOFL,PSOOCNT
- N PSODMESE,PSODMESX,PSODMESG,PSODMEST,PSODMESH,PSODMESM,PSORLNF
- S (PSODLERF,PSODSEQ,PSODLWW,PSOOFL,PSORLNF)="",PSOOCNT=0
- F S PSODSEQ=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ)) Q:PSODSEQ=""!($G(PSORX("DFLG")))!($G(PSODLQTC)) S PSODLNN1="" D D HD Q:$G(PSODLQTC)
- .S:PSODTYPE'="N" PSODLQT=0 S PSOLASTS=PSODSEQ
- .I PSODTYPE="C" K PSOCPXRR
- .F S PSODLNN1=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1)) Q:PSODLNN1=""!($G(PSORX("DFLG")))!($G(PSODLQTC)) D
- ..S:PSODTYPE'="E" PSODLECT=0
- ..I PSODTYPE="E" Q:$P(PSODLNN1,";",4)'=PSODLXNT
- ..S PSOOCNT=PSOOCNT+1 I PSOOCNT>1,PSOCPXB=2!(PSOCPXB=3) W !
- ..D EXCEPT^PSODOSUT,SETV
- ..D ERROR Q:$G(PSODLQTC) I PSODLERZ,'PSODMESX,'PSODMESM W ! I PSODTYPE'="E" W !
- ..D EXCEPT Q:$G(PSODLQTC) I PSODLERZ,'PSODMESM W ! I PSODTYPE'="E" W !
- ..D MESSAGE Q:$G(PSODLQTC)
- .K PSODLWW
- Q
- ;
- ERROR ;format and write dosing error
- I PSODTYPE'="E" S PSODLECT=0
- F PSODLERA=0:0 S PSODLERA=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"ERROR",PSODLERA)) Q:'PSODLERA!($G(PSORX("DFLG"))) D
- .S:PSODTYPE'="E" PSODLECT=PSODLECT+1
- .S:PSODTYPE'="N" PSODLQT=0
- .F PSODLERX="MSG","TEXT" S PSODLERB=$G(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"ERROR",PSODLERA,PSODLERX)) D K ^UTILITY($J,"W")
- ..S PSODLERZ=0 Q:PSODLERB=""
- ..I PSODTYPE="C"&(PSOCPXB>3) D ERRCOM Q
- ..I PSODTYPE="E" D ERREDIT Q
- ..I PSODTYPE="N"&(PSOCPXB>3) D ERRNEW Q
- ..Q:PSODTYPE="C"&(PSOCPXB<4)
- ..D ERRNEW
- I PSODTYPE="E",PSODMESG W !
- Q
- ;
- ERRCOM ;write dosing errors for complex dose summary after accept of an order
- I PSOCPXC D HD Q:$G(PSODLQTC) I PSODLERF,PSODLERX="MSG" W:'PSODLQT ! D HD Q:$G(PSODLQTC)
- I 'PSODLERF,PSOCPXB<4 W:'PSODLQT&(PSOCPXC) !
- S PSODLERF=1 D:PSOCPXC HD I PSODLERZ W:'PSODLQT&(PSOCPXC) !
- D:PSOCPXC
- .D HD Q:$G(PSODLQTC) W:'PSODLQT&(PSODLECT>1) !
- .N X,DIWL,DIWR,DIWF,PSODELXR,PSODELXF
- .D:PSOCPXC HD D:'PSOCPXF&(PSOCPXC)
- ..Q:$G(PSORENWD)&(PSOCPXB<4) D SUMM^PSODOSUT
- .D:PSOCPXC HD S PSOCPXG=$P(PSODLNN1,";",4) I PSOCPXC&('$G(PSOCPXRR(PSOCPXG))) D PSOORI,SUB^PSODOSUT W:'PSODLQT&('PSODLERZ) !
- .D:PSOCPXC HD W:'PSODLQT&(PSODLECT'>1)&(PSODLERX="TEXT")&(PSOCPXC) ! S X=PSODLERB,DIWL=1,DIWR=$S(PSODLERX="MSG":76,1:74) K ^UTILITY($J,"W") D ^DIWP
- .S PSODELXF=0 F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR D:PSOCPXC HD W:PSODELXF&('PSODLQT) ! D
- ..D:PSOCPXC HD W:'$G(PSODLQT) $S(PSODLERX="MSG":" ",1:" ")_$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) S (PSODLERR,PSODOSER,PSODLEXR,PSOERROR)=1 D SFD
- .S PSOLASTD(PSOLASTS)=1,PSONFRNF=1
- Q
- ;
- ERREDIT ;write dosing errors for edits or display during complex dose entry
- I 'PSODLERF,PSOCPXB<4 W:'PSODLQT !
- D HD Q:$G(PSODLQTC) I PSODLERF,PSODLERX="MSG" W:'PSODLQT ! D HD Q:$G(PSODLQTC) I 'PSODLERF W:'PSODLQT !
- S PSODLERF=1 D HD Q:$G(PSODLQTC) I PSODLERZ W:'PSODLQT !
- D HD Q:$G(PSODLQTC) W:'PSODLQT !
- N X,DIWL,DIWR,DIWF,PSODELXR,PSODELXF S X=PSODLERB,DIWL=1,DIWR=$S(PSODLERX="MSG":76,1:74) K ^UTILITY($J,"W") D ^DIWP
- S PSODELXF=0 F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR D HD Q:$G(PSODLQTC) W:PSODELXF&('PSODLQT) ! D HD Q:$G(PSODLQTC) D
- .W:'PSODLQT $S(PSODLERX="MSG":" ",1:" ")_$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) S (PSODLERR,PSODOSER,PSODLEXR,PSOERROR)=1 D SFD
- S PSOLASTD(PSOLASTS)=1,PSONFRNF=1
- Q
- ;
- ERRNEW ;write dosing errors for finish, new, copy, renewal and verify
- D HD Q:$G(PSODLQTC) I PSODLERF,PSODLERX="MSG" W:'PSODLQT ! D HD Q:$G(PSODLQTC)
- I $L(PSODLERB)>76&(PSOCPXB>1) S PSODLERL=1
- I 'PSODLERF,PSOCPXB<4 W:'PSODLQT !
- S PSODLERF=1 D HD Q:$G(PSODLQTC) I PSODLERZ W:'PSODLQT !
- D HD Q:$G(PSODLQTC) W:'PSODLQT&(PSODLECT>1) ! N X,DIWL,DIWR,DIWF,PSODELXR,PSODELXF
- D:PSOCPXC HD D:'PSOCPXF&(PSOCPXC)
- .Q:$G(PSORENWD)&(PSOCPXB<4) D SUMM^PSODOSUT
- D HD Q:$G(PSODLQTC) S PSOCPXG=$P(PSODLNN1,";",4) I '$G(PSOCPXRR(PSOCPXG))&(PSOCPXB>1) D PSOORI,SUB^PSODOSUT W:'PSODLQT&('PSODLERZ) !
- D HD Q:$G(PSODLQTC) W:'PSODLQT&(PSODLECT'>1)&(PSODLERX="TEXT") ! S X=PSODLERB,DIWL=1,DIWR=$S(PSODLERX="MSG":76,1:74) K ^UTILITY($J,"W") D ^DIWP
- S PSODELXF=0 F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR D HD Q:$G(PSODLQTC) W:PSODELXF&('PSODLQT) ! D HD Q:$G(PSODLQTC) D
- .W:'PSODLQT $S(PSODLERX="MSG":" ",1:" ")_$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) S (PSODLERR,PSODOSER,PSODLEXR,PSOERROR)=1 D SFD
- S PSOLASTD(PSOLASTS)=1,PSONFRNF=1
- Q
- ;
- SFD ;
- S PSODELXF=1 S:PSODLERX="TEXT" PSODLERZ=1
- Q
- ;
- EXCEPT ;format and write exceptions
- I PSODTYPE="E" S (PSODLERZ)=0
- I $G(PSODOSER),PSODTYPE="N",PSODMESX,PSODMESG W !
- I $G(PSODOSER) K PSODOSER I PSODMESX,'PSODMESG W ! ;line feed between error and exceptions
- I PSODTYPE="N" D HD Q:$G(PSODLQTC) W:PSODLERF&('PSODLQT)&('PSODMESX)&('PSODMESM) ! S PSODLERZ=0
- I PSODTYPE="C" D:PSOCPXC HD W:PSODLERF&(PSOCPXC)&('PSODLQT)&('PSODMESX)&('PSODMESM)&('$G(PSODLWW)) ! S (PSODLERZ,PSODLESM)=0
- F PSODLERA=0:0 S PSODLERA=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"EXCEPTIONS",PSODLERA)) Q:'PSODLERA D
- .S PSODLERB=$G(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"EXCEPTIONS",PSODLERA))
- .I PSODTYPE="N" D SBAD^PSODOSUT
- .I PSODTYPE="E"!(PSODTYPE="C") D SBAD^PSODOSUT:PSODLERB'=""
- .Q:PSODLERB="" I PSODTYPE'="C" D HD Q:$G(PSODLQTC)
- .S (PSODLERF,PSODLALZ)=1
- .;write exceptions for new, copy, renew, verify
- .I PSODTYPE="N" D Q
- ..D HD Q:$G(PSODLQTC) I 'PSOCPXF&(PSOCPXC) D
- ...Q:$G(PSORENWD)&(PSOCPXB<4) D SUMM^PSODOSUT
- ..I 'PSODLERF W:'PSODLQT&('$G(PSODLWW)) ! D HD Q:$G(PSODLQTC) S PSODLWW=0
- ..S PSOCPXG=$P(PSODLNN1,";",4)
- ..I '$G(PSOCPXRR(PSOCPXG)),PSOCPXB>1 W:'PSODLQT&(PSODLERZ) ! D PSOORI,SUB^PSODOSUT
- ..D HD Q:$G(PSODLQTC) W:'PSODLQT&('$G(PSODLWW)) ! S PSODLWW=0
- ..D WRITEXC
- .;write dosing exceptions for edits or display during complex dose entry
- .I PSODTYPE="E" D
- ..I PSODLERB["please complete a manual check for appropriate Dosing" S PSODCONT=1
- ..D HD Q:$G(PSODLQTC) W:'PSODLQT&('$G(PSODLWW)) ! S PSODLWW=0
- ..D WRITEXC
- .;write exceptions for complex orders
- .I PSODTYPE="C"&(PSOCPXB>3) D
- ..D:PSOCPXC HD I 'PSODLERF&('$G(PSODLWW)) W:'PSODLQT&(PSOCPXC) !
- ..D:PSOCPXC
- ...D HD Q:$G(PSODLQTC) I 'PSOCPXF&(PSOCPXC) D
- ....Q:$G(PSORENWD)&(PSOCPXB<4) D SUMM^PSODOSUT
- ...S PSOCPXG=$P(PSODLNN1,";",4) I PSOCPXC&('$G(PSOCPXRR(PSOCPXG))) D HD Q:$G(PSODLQTC) W:'PSODLQT&(PSOCPXC)&(PSODLESM)&('$G(PSODLWW)) ! D PSOORI,SUB^PSODOSUT
- ...S PSODLESM=1 D HD Q:$G(PSODLQTC) W:'PSODLQT&('$G(PSODLWW)) !
- ...D:PSOCPXC WRITEXC
- Q
- ;
- WRITEXC ;format and write exception messages to the screen
- D WRITEXC^PSODOSU4 Q
- ;
- MESSAGE ;format and write messages
- I PSODTYPE="N",$$FEED^PSODOSUT D HD Q:$G(PSODLQTC) W:'PSODLQT !
- I $G(PSODLERZ)&('PSODLQT)&(PSODTYPE'="N") W ! ;line feed for transition between exceptions to messages
- I PSODTYPE="C" I $$FEED^PSODOSUT&(PSOCPXC) D HD Q:$G(PSODLQTC) W:'PSODLQT !
- S PSODLPL="" F S PSODLPL=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL)) Q:PSODLPL="" D
- .;Add a line feed if there are just Single and General dosing messages
- .I PSODLPL="3_GENERAL" D
- ..I PSODTYPE="N" D Q
- ...I PSODLINS,'PSODLINR,'PSODLINX W ! Q
- ...I 'PSODLINS,'PSODLINR,'PSODLINX W !!
- ..W !
- .I PSODLPL=".1_INTRO" D
- ..S PSOINTRO="1^"_$G(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",".1_INTRO"))
- ..I $P(PSOINTRO,U,2)="" S PSOINTRO=0
- .F PSODLP1=0:0 S PSODLP1=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1)) Q:'PSODLP1 D
- ..I PSODTYPE'="C",PSODLPL="3_GENERAL" D GENERAL Q
- ..S PSODLMSG=$G(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1))
- ..Q:PSODLMSG=""
- ..I 'PSODLERF W:'PSODLQT&('$G(PSODLWW)) ! D HD Q:$G(PSODLQTC)
- ..S PSODLERF=1
- ..I PSODTYPE'="C" D HD Q:$G(PSODLQTC) I 'PSODLQT,'$G(PSODLWW),$G(PSODLERR),'PSORLNF W ! S PSORLNF=1
- ..I PSODTYPE="C" D Q:'PSODLQT&(PSOCPXC)&(PSODLESM) I PSOCPXF&(PSOCPXC) K PSODAILY
- ...D:PSOCPXC HD I '$G(PSODLFLG) W:'PSODLQT&(PSOCPXC)&(PSOCPXF)&('$G(PSODLWW)) !
- ...S PSODLFLG=1 S PSODLEXR=0
- ..I PSODTYPE'="E" S PSODLEXR=0
- ..S PSODLFLG=1 S:PSODLPL="1_SINGLE" PSODLINS=1 S:PSODLPL="2_RANGE" PSODLINR=1 S:PSODLPL="1_SINGLE_RANGE" PSODLINX=1
- ..I PSODTYPE="N" S PSODLFLG=1 D MSGN
- ..I PSODTYPE="E" S PSODLFLG=1 D WRITMSG
- ..I PSODTYPE="C"&(PSOCPXB>3) D MSGC
- .I PSODLPL="4_TRAIL",PSODTYPE="E"!(PSODTYPE="N") D
- ..S PSODLMSG=$G(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","4_TRAIL"))
- ..D WRITMSG
- Q
- ;
- MSGN ;write dosing message for new, copy, renew, and verify
- I 'PSOCPXF&(PSOCPXC)&($G(PSOCPXB)>3) S PSOCPXG=$P(PSODLNN1,";",4) D K PSODAILY S:PSOCPXC&(PSOCPXG=PSOCPXB) PSOCPXH=1
- .Q:$G(PSORENWD)&(PSOCPXB<4) D SUMM^PSODOSUT
- S PSOCPXG=$P(PSODLNN1,";",4) D HD Q:$G(PSODLQTC) D:'$G(PSOCPXRR(PSOCPXG))&(PSOCPXB>1) PSOORI,SUB^PSODOSUT D
- .I $G(PSOCPXRR(PSOCPXG))&$P(PSODLNN1,";",5)'="" K PSODAILY
- .I PSODLPL="2_RANGE",'$G(PSODAILY) D DAILY^PSODOSUT I PSOCPXG'=PSOCPXB K PSODAILY
- .I PSODLPL="1_SINGLE_RANGE",'$G(PSODAILY) D DAILY^PSODOSUT I PSOCPXG'=PSOCPXB K PSODAILY
- .D HD Q:$G(PSODLQTC) D WRITMSG,HD Q:$G(PSODLQTC)
- Q
- ;
- MSGC ;write dosing message for edits or display during complex dose entry
- Q:'PSODLQT&(PSOCPXC)&(PSODLESM) I PSOCPXF&(PSOCPXC) K PSODAILY
- D:PSOCPXC HD Q:$G(PSODLQTC)
- I 'PSOCPXF&(PSOCPXC) S PSOCPXG=$P(PSODLNN1,";",4) D K PSODAILY S:PSOCPXC&(PSOCPXG=PSOCPXB) PSOCPXH=1
- .Q:$G(PSORENWD)&(PSOCPXB<4) D SUMM^PSODOSUT
- I PSOCPXC S PSOCPXG=$P(PSODLNN1,";",4) D HD Q:$G(PSODLQTC) D
- .I $G(PSOCPXRR(PSOCPXG))&$P(PSODLNN1,";",5)'="" K PSODAILY
- .I '$G(PSOCPXRR(PSOCPXG))&('$G(PSOCPXH)) D PSOORI,SUB^PSODOSUT I $G(PSOCOPY)!($G(PSORENW)) S:PSOCPXC&(PSOCPXG=PSOCPXB) PSOCPXH=1
- .I PSODLPL="2_RANGE"&PSODLINR&'$G(PSODAILY) D DAILY^PSODOSUT
- .I PSODLPL="1_SINGLE_RANGE"&PSODLINX&'$G(PSODAILY) D DAILY^PSODOSUT
- .D WRITMSG
- Q
- ;
- WRITMSG ;
- W:'PSODLQT&('$G(PSODLWW)) ! S PSODLWW=0
- N X,DIWL,DIWR,DIWF
- IF +$G(PSOINTRO),'$G(PSOOFL) D
- .S X=$P(PSOINTRO,U,2),DIWL=1,DIWR=76 K ^UTILITY($J,"W") D ^DIWP
- .D WRITMSG1
- .W !
- .S $P(PSOINTRO,U)=0
- S X=PSODLMSG,DIWL=1,DIWR=76 K ^UTILITY($J,"W") D ^DIWP
- D WRITMSG1
- K ^UTILITY($J,"W") D HD Q:$G(PSODLQTC)
- I PSODTYPE="E",'PSODLQT S PSODELNX=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1)) I '$P($G(PSODELNX),";",5) W !
- I PSODTYPE="C"!(PSODTYPE="N"),'PSODLQT D
- .D HD Q:$G(PSODLQTC) S PSODELNX=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1)) I '$P($G(PSODELNX),";",5)!($P($G(PSODELNX),";",4)'=PSOCPXG) W ! S PSOLASTD(PSOLASTS)=3
- Q
- ;
- WRITMSG1 ;
- N PSODELXR,PSODELXF,PSOSPACE
- S PSODELXF=0
- S PSOSPACE=" "
- I +$G(PSOINTRO),'$G(PSOOFL) S PSOSPACE=""
- F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR D
- .D HD Q:$G(PSODLQTC) W:PSODELXF&('PSODLQT) ! W:'PSODLQT PSOSPACE_$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) S (PSODLFLG,PSODELXF,PSONFRNF,PSOWMSG,PSODLEXR)=1
- I $G(PSODLFLG)&($G(PSOCPXC))&($G(PSOCPXB)>3)!(PSODTYPE="C"&(PSOCPXB>3)) W !
- Q
- ;
- WRTINTRO ;
- N PSODELXR
- F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR!($G(PSODLQTC)) D
- .D HD Q:$G(PSODLQTC) W $G(^UTILITY($J,"W",DIWL,PSODELXR,0))
- .I PSODLPL'="3_GENERAL" W !
- .S $P(PSOINTRO,U)=0
- Q
- ;
- GENERAL ;general dosing range information
- N PSODLERC,PSODLP2
- I +$G(PSOINTRO) D
- .S X=$P(PSOINTRO,U,2),DIWL=4,DIWR=76 K ^UTILITY($J,"W") D ^DIWP
- .D WRTINTRO
- F PSODLP2=0:0 S PSODLP2=$O(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1,PSODLP2)) Q:'PSODLP2!($G(PSORX("DFLG"))) D
- .S PSODLERC="",PSODLERC=$G(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1,PSODLP2))
- .Q:PSODLERC=""
- .D HD Q:$G(PSODLQTC)
- .;I 'PSODLQT,'$G(PSOEDIT) W !
- .N X,DIWL,DIWR,DIWF,DIWL,PSODELXR,PSODELXF S PSODLEXR=1
- .S DIWL=4,DIWR=76 K ^UTILITY($J,"W")
- .S X=PSODLERC D ^DIWP
- .S PSODELXF=0 F PSODELXR=0:0 S PSODELXR=$O(^UTILITY($J,"W",DIWL,PSODELXR)) Q:'PSODELXR D HD Q:$G(PSODLQTC) W:PSODELXF&('PSODLQT) ! D HD Q:$G(PSODLQTC) W:'PSODLQT " "_$G(^UTILITY($J,"W",DIWL,PSODELXR,0)) S (PSODELXF,PSODLERZ,PSONFRNF)=1
- .S PSOLASTD(PSOLASTS)=3
- .I '$D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE")),'$D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","2_RANGE")),'$D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE_RANGE")) D
- ..I +$G(PSOEXCPT)!(+$G(PSOERROR)) S PSOGENF=1
- .K ^UTILITY($J,"W")
- .W !
- Q
- ;
- HD ;
- S:'$G(PSODLQT) PSODLQT=""
- I PSODLQT!(($Y+3)<IOSL)!($G(PSORX("DFLG"))) Q
- W:$G(PSORENWD) !
- HD2 ;
- N DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
- K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue,'^' to exit" D ^DIR K DIR
- I $G(PSOCPXC)&($D(DIRUT)!($D(DUOUT))) S PSODLQTC=1 W @IOF W ! Q ;user ^'s
- I 'Y!($D(DTOUT))!($D(DUOUT))!($G(DIRUT)) S PSODLQT=1,PSORX("DFLG")=1 Q
- W @IOF W !
- S PSOOFL="" D:$G(PSODELXR) PSOORI W:$G(PSOOFL) !
- Q
- ;
- PSOORI ;**writes per orifice intro text to the screen for dosing check summary**
- I +$G(PSOINTRO),'$G(PSOOFL) D
- .W ?3,$P(PSOINTRO,U,2),!
- .S $P(PSOINTRO,U)=0,PSOOFL=1
- Q
- ;
- SETV ; Set variables indicating what messages exist
- S (PSODMESE,PSODMESX,PSODMESG,PSODMEST,PSODMESH,PSODMESM)=0
- I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"ERROR")) S PSODMESE=1
- I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"EXCEPTIONS")) S PSODMESX=1
- I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE")) S PSODMESM=1
- I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","3_GENERAL")) S PSODMESG=1
- I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","4_TRAIL")) S PSODMEST=1
- D
- .I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE")) S PSODMESH=1 Q
- .I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","2_RANGE")) S PSODMESH=1 Q
- .I $D(^TMP($J,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE_RANGE")) S PSODMESH=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODOSU2 14236 printed Feb 18, 2025@23:53:41 Page 2
- PSODOSU2 ;BIR/RTR - Dose Check Utility routine continued ;11/18/08
- +1 ;;7.0;OUTPATIENT PHARMACY;**251,375,372,436,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 ;
- EN ;new order, copy, renew, and verify orders
- +1 NEW PSODLERW,PSODLERL,PSODLERS,PSODLERH,PSOCPXRR,PSODLWW,PSODOSER,PSONFRNF,PSOWMSG,PSODLQTC,PSOOFL,PSOOCNT
- +2 NEW PSODMESE,PSODMESX,PSODMESG,PSODMEST,PSODMESH,PSODMESM,PSORLNF
- +3 SET (PSODLERF,PSODSEQ,PSODLWW,PSOOFL,PSORLNF)=""
- SET PSOOCNT=0
- +4 FOR
- SET PSODSEQ=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ))
- if PSODSEQ=""!($GET(PSORX("DFLG")))!($GET(PSODLQTC))
- QUIT
- SET PSODLNN1=""
- Begin DoDot:1
- +5 if PSODTYPE'="N"
- SET PSODLQT=0
- SET PSOLASTS=PSODSEQ
- +6 IF PSODTYPE="C"
- KILL PSOCPXRR
- +7 FOR
- SET PSODLNN1=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1))
- if PSODLNN1=""!($GET(PSORX("DFLG")))!($GET(PSODLQTC))
- QUIT
- Begin DoDot:2
- +8 if PSODTYPE'="E"
- SET PSODLECT=0
- +9 IF PSODTYPE="E"
- if $PIECE(PSODLNN1,";",4)'=PSODLXNT
- QUIT
- +10 SET PSOOCNT=PSOOCNT+1
- IF PSOOCNT>1
- IF PSOCPXB=2!(PSOCPXB=3)
- WRITE !
- +11 DO EXCEPT^PSODOSUT
- DO SETV
- +12 DO ERROR
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERZ
- IF 'PSODMESX
- IF 'PSODMESM
- WRITE !
- IF PSODTYPE'="E"
- WRITE !
- +13 DO EXCEPT
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERZ
- IF 'PSODMESM
- WRITE !
- IF PSODTYPE'="E"
- WRITE !
- +14 DO MESSAGE
- if $GET(PSODLQTC)
- QUIT
- End DoDot:2
- +15 KILL PSODLWW
- End DoDot:1
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +16 QUIT
- +17 ;
- ERROR ;format and write dosing error
- +1 IF PSODTYPE'="E"
- SET PSODLECT=0
- +2 FOR PSODLERA=0:0
- SET PSODLERA=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"ERROR",PSODLERA))
- if 'PSODLERA!($GET(PSORX("DFLG")))
- QUIT
- Begin DoDot:1
- +3 if PSODTYPE'="E"
- SET PSODLECT=PSODLECT+1
- +4 if PSODTYPE'="N"
- SET PSODLQT=0
- +5 FOR PSODLERX="MSG","TEXT"
- SET PSODLERB=$GET(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"ERROR",PSODLERA,PSODLERX))
- Begin DoDot:2
- +6 SET PSODLERZ=0
- if PSODLERB=""
- QUIT
- +7 IF PSODTYPE="C"&(PSOCPXB>3)
- DO ERRCOM
- QUIT
- +8 IF PSODTYPE="E"
- DO ERREDIT
- QUIT
- +9 IF PSODTYPE="N"&(PSOCPXB>3)
- DO ERRNEW
- QUIT
- +10 if PSODTYPE="C"&(PSOCPXB<4)
- QUIT
- +11 DO ERRNEW
- End DoDot:2
- KILL ^UTILITY($JOB,"W")
- End DoDot:1
- +12 IF PSODTYPE="E"
- IF PSODMESG
- WRITE !
- +13 QUIT
- +14 ;
- ERRCOM ;write dosing errors for complex dose summary after accept of an order
- +1 IF PSOCPXC
- DO HD
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERF
- IF PSODLERX="MSG"
- if 'PSODLQT
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +2 IF 'PSODLERF
- IF PSOCPXB<4
- if 'PSODLQT&(PSOCPXC)
- WRITE !
- +3 SET PSODLERF=1
- if PSOCPXC
- DO HD
- IF PSODLERZ
- if 'PSODLQT&(PSOCPXC)
- WRITE !
- +4 if PSOCPXC
- Begin DoDot:1
- +5 DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&(PSODLECT>1)
- WRITE !
- +6 NEW X,DIWL,DIWR,DIWF,PSODELXR,PSODELXF
- +7 if PSOCPXC
- DO HD
- if 'PSOCPXF&(PSOCPXC)
- Begin DoDot:2
- +8 if $GET(PSORENWD)&(PSOCPXB<4)
- QUIT
- DO SUMM^PSODOSUT
- End DoDot:2
- +9 if PSOCPXC
- DO HD
- SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- IF PSOCPXC&('$GET(PSOCPXRR(PSOCPXG)))
- DO PSOORI
- DO SUB^PSODOSUT
- if 'PSODLQT&('PSODLERZ)
- WRITE !
- +10 if PSOCPXC
- DO HD
- if 'PSODLQT&(PSODLECT'>1)&(PSODLERX="TEXT")&(PSOCPXC)
- WRITE !
- SET X=PSODLERB
- SET DIWL=1
- SET DIWR=$SELECT(PSODLERX="MSG":76,1:74)
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- +11 SET PSODELXF=0
- FOR PSODELXR=0:0
- SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
- if 'PSODELXR
- QUIT
- if PSOCPXC
- DO HD
- if PSODELXF&('PSODLQT)
- WRITE !
- Begin DoDot:2
- +12 if PSOCPXC
- DO HD
- if '$GET(PSODLQT)
- WRITE $SELECT(PSODLERX="MSG":" ",1:" ")_$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
- SET (PSODLERR,PSODOSER,PSODLEXR,PSOERROR)=1
- DO SFD
- End DoDot:2
- +13 SET PSOLASTD(PSOLASTS)=1
- SET PSONFRNF=1
- End DoDot:1
- +14 QUIT
- +15 ;
- ERREDIT ;write dosing errors for edits or display during complex dose entry
- +1 IF 'PSODLERF
- IF PSOCPXB<4
- if 'PSODLQT
- WRITE !
- +2 DO HD
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERF
- IF PSODLERX="MSG"
- if 'PSODLQT
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- IF 'PSODLERF
- if 'PSODLQT
- WRITE !
- +3 SET PSODLERF=1
- DO HD
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERZ
- if 'PSODLQT
- WRITE !
- +4 DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT
- WRITE !
- +5 NEW X,DIWL,DIWR,DIWF,PSODELXR,PSODELXF
- SET X=PSODLERB
- SET DIWL=1
- SET DIWR=$SELECT(PSODLERX="MSG":76,1:74)
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- +6 SET PSODELXF=0
- FOR PSODELXR=0:0
- SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
- if 'PSODELXR
- QUIT
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if PSODELXF&('PSODLQT)
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- Begin DoDot:1
- +7 if 'PSODLQT
- WRITE $SELECT(PSODLERX="MSG":" ",1:" ")_$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
- SET (PSODLERR,PSODOSER,PSODLEXR,PSOERROR)=1
- DO SFD
- End DoDot:1
- +8 SET PSOLASTD(PSOLASTS)=1
- SET PSONFRNF=1
- +9 QUIT
- +10 ;
- ERRNEW ;write dosing errors for finish, new, copy, renewal and verify
- +1 DO HD
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERF
- IF PSODLERX="MSG"
- if 'PSODLQT
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +2 IF $LENGTH(PSODLERB)>76&(PSOCPXB>1)
- SET PSODLERL=1
- +3 IF 'PSODLERF
- IF PSOCPXB<4
- if 'PSODLQT
- WRITE !
- +4 SET PSODLERF=1
- DO HD
- if $GET(PSODLQTC)
- QUIT
- IF PSODLERZ
- if 'PSODLQT
- WRITE !
- +5 DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&(PSODLECT>1)
- WRITE !
- NEW X,DIWL,DIWR,DIWF,PSODELXR,PSODELXF
- +6 if PSOCPXC
- DO HD
- if 'PSOCPXF&(PSOCPXC)
- Begin DoDot:1
- +7 if $GET(PSORENWD)&(PSOCPXB<4)
- QUIT
- DO SUMM^PSODOSUT
- End DoDot:1
- +8 DO HD
- if $GET(PSODLQTC)
- QUIT
- SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- IF '$GET(PSOCPXRR(PSOCPXG))&(PSOCPXB>1)
- DO PSOORI
- DO SUB^PSODOSUT
- if 'PSODLQT&('PSODLERZ)
- WRITE !
- +9 DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&(PSODLECT'>1)&(PSODLERX="TEXT")
- WRITE !
- SET X=PSODLERB
- SET DIWL=1
- SET DIWR=$SELECT(PSODLERX="MSG":76,1:74)
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- +10 SET PSODELXF=0
- FOR PSODELXR=0:0
- SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
- if 'PSODELXR
- QUIT
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if PSODELXF&('PSODLQT)
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- Begin DoDot:1
- +11 if 'PSODLQT
- WRITE $SELECT(PSODLERX="MSG":" ",1:" ")_$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
- SET (PSODLERR,PSODOSER,PSODLEXR,PSOERROR)=1
- DO SFD
- End DoDot:1
- +12 SET PSOLASTD(PSOLASTS)=1
- SET PSONFRNF=1
- +13 QUIT
- +14 ;
- SFD ;
- +1 SET PSODELXF=1
- if PSODLERX="TEXT"
- SET PSODLERZ=1
- +2 QUIT
- +3 ;
- EXCEPT ;format and write exceptions
- +1 IF PSODTYPE="E"
- SET (PSODLERZ)=0
- +2 IF $GET(PSODOSER)
- IF PSODTYPE="N"
- IF PSODMESX
- IF PSODMESG
- WRITE !
- +3 ;line feed between error and exceptions
- IF $GET(PSODOSER)
- KILL PSODOSER
- IF PSODMESX
- IF 'PSODMESG
- WRITE !
- +4 IF PSODTYPE="N"
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if PSODLERF&('PSODLQT)&('PSODMESX)&('PSODMESM)
- WRITE !
- SET PSODLERZ=0
- +5 IF PSODTYPE="C"
- if PSOCPXC
- DO HD
- if PSODLERF&(PSOCPXC)&('PSODLQT)&('PSODMESX)&('PSODMESM)&('$GET(PSODLWW))
- WRITE !
- SET (PSODLERZ,PSODLESM)=0
- +6 FOR PSODLERA=0:0
- SET PSODLERA=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"EXCEPTIONS",PSODLERA))
- if 'PSODLERA
- QUIT
- Begin DoDot:1
- +7 SET PSODLERB=$GET(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"EXCEPTIONS",PSODLERA))
- +8 IF PSODTYPE="N"
- DO SBAD^PSODOSUT
- +9 IF PSODTYPE="E"!(PSODTYPE="C")
- if PSODLERB'=""
- DO SBAD^PSODOSUT
- +10 if PSODLERB=""
- QUIT
- IF PSODTYPE'="C"
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +11 SET (PSODLERF,PSODLALZ)=1
- +12 ;write exceptions for new, copy, renew, verify
- +13 IF PSODTYPE="N"
- Begin DoDot:2
- +14 DO HD
- if $GET(PSODLQTC)
- QUIT
- IF 'PSOCPXF&(PSOCPXC)
- Begin DoDot:3
- +15 if $GET(PSORENWD)&(PSOCPXB<4)
- QUIT
- DO SUMM^PSODOSUT
- End DoDot:3
- +16 IF 'PSODLERF
- if 'PSODLQT&('$GET(PSODLWW))
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- SET PSODLWW=0
- +17 SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- +18 IF '$GET(PSOCPXRR(PSOCPXG))
- IF PSOCPXB>1
- if 'PSODLQT&(PSODLERZ)
- WRITE !
- DO PSOORI
- DO SUB^PSODOSUT
- +19 DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&('$GET(PSODLWW))
- WRITE !
- SET PSODLWW=0
- +20 DO WRITEXC
- End DoDot:2
- QUIT
- +21 ;write dosing exceptions for edits or display during complex dose entry
- +22 IF PSODTYPE="E"
- Begin DoDot:2
- +23 IF PSODLERB["please complete a manual check for appropriate Dosing"
- SET PSODCONT=1
- +24 DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&('$GET(PSODLWW))
- WRITE !
- SET PSODLWW=0
- +25 DO WRITEXC
- End DoDot:2
- +26 ;write exceptions for complex orders
- +27 IF PSODTYPE="C"&(PSOCPXB>3)
- Begin DoDot:2
- +28 if PSOCPXC
- DO HD
- IF 'PSODLERF&('$GET(PSODLWW))
- if 'PSODLQT&(PSOCPXC)
- WRITE !
- +29 if PSOCPXC
- Begin DoDot:3
- +30 DO HD
- if $GET(PSODLQTC)
- QUIT
- IF 'PSOCPXF&(PSOCPXC)
- Begin DoDot:4
- +31 if $GET(PSORENWD)&(PSOCPXB<4)
- QUIT
- DO SUMM^PSODOSUT
- End DoDot:4
- +32 SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- IF PSOCPXC&('$GET(PSOCPXRR(PSOCPXG)))
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&(PSOCPXC)&(PSODLESM)&('$GET(PSODLWW))
- WRITE !
- DO PSOORI
- DO SUB^PSODOSUT
- +33 SET PSODLESM=1
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT&('$GET(PSODLWW))
- WRITE !
- +34 if PSOCPXC
- DO WRITEXC
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +35 QUIT
- +36 ;
- WRITEXC ;format and write exception messages to the screen
- +1 DO WRITEXC^PSODOSU4
- QUIT
- +2 ;
- MESSAGE ;format and write messages
- +1 IF PSODTYPE="N"
- IF $$FEED^PSODOSUT
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT
- WRITE !
- +2 ;line feed for transition between exceptions to messages
- IF $GET(PSODLERZ)&('PSODLQT)&(PSODTYPE'="N")
- WRITE !
- +3 IF PSODTYPE="C"
- IF $$FEED^PSODOSUT&(PSOCPXC)
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT
- WRITE !
- +4 SET PSODLPL=""
- FOR
- SET PSODLPL=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL))
- if PSODLPL=""
- QUIT
- Begin DoDot:1
- +5 ;Add a line feed if there are just Single and General dosing messages
- +6 IF PSODLPL="3_GENERAL"
- Begin DoDot:2
- +7 IF PSODTYPE="N"
- Begin DoDot:3
- +8 IF PSODLINS
- IF 'PSODLINR
- IF 'PSODLINX
- WRITE !
- QUIT
- +9 IF 'PSODLINS
- IF 'PSODLINR
- IF 'PSODLINX
- WRITE !!
- End DoDot:3
- QUIT
- +10 WRITE !
- End DoDot:2
- +11 IF PSODLPL=".1_INTRO"
- Begin DoDot:2
- +12 SET PSOINTRO="1^"_$GET(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",".1_INTRO"))
- +13 IF $PIECE(PSOINTRO,U,2)=""
- SET PSOINTRO=0
- End DoDot:2
- +14 FOR PSODLP1=0:0
- SET PSODLP1=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1))
- if 'PSODLP1
- QUIT
- Begin DoDot:2
- +15 IF PSODTYPE'="C"
- IF PSODLPL="3_GENERAL"
- DO GENERAL
- QUIT
- +16 SET PSODLMSG=$GET(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1))
- +17 if PSODLMSG=""
- QUIT
- +18 IF 'PSODLERF
- if 'PSODLQT&('$GET(PSODLWW))
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +19 SET PSODLERF=1
- +20 IF PSODTYPE'="C"
- DO HD
- if $GET(PSODLQTC)
- QUIT
- IF 'PSODLQT
- IF '$GET(PSODLWW)
- IF $GET(PSODLERR)
- IF 'PSORLNF
- WRITE !
- SET PSORLNF=1
- +21 IF PSODTYPE="C"
- Begin DoDot:3
- +22 if PSOCPXC
- DO HD
- IF '$GET(PSODLFLG)
- if 'PSODLQT&(PSOCPXC)&(PSOCPXF)&('$GET(PSODLWW))
- WRITE !
- +23 SET PSODLFLG=1
- SET PSODLEXR=0
- End DoDot:3
- if 'PSODLQT&(PSOCPXC)&(PSODLESM)
- QUIT
- IF PSOCPXF&(PSOCPXC)
- KILL PSODAILY
- +24 IF PSODTYPE'="E"
- SET PSODLEXR=0
- +25 SET PSODLFLG=1
- if PSODLPL="1_SINGLE"
- SET PSODLINS=1
- if PSODLPL="2_RANGE"
- SET PSODLINR=1
- if PSODLPL="1_SINGLE_RANGE"
- SET PSODLINX=1
- +26 IF PSODTYPE="N"
- SET PSODLFLG=1
- DO MSGN
- +27 IF PSODTYPE="E"
- SET PSODLFLG=1
- DO WRITMSG
- +28 IF PSODTYPE="C"&(PSOCPXB>3)
- DO MSGC
- End DoDot:2
- +29 IF PSODLPL="4_TRAIL"
- IF PSODTYPE="E"!(PSODTYPE="N")
- Begin DoDot:2
- +30 SET PSODLMSG=$GET(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","4_TRAIL"))
- +31 DO WRITMSG
- End DoDot:2
- End DoDot:1
- +32 QUIT
- +33 ;
- MSGN ;write dosing message for new, copy, renew, and verify
- +1 IF 'PSOCPXF&(PSOCPXC)&($GET(PSOCPXB)>3)
- SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- Begin DoDot:1
- +2 if $GET(PSORENWD)&(PSOCPXB<4)
- QUIT
- DO SUMM^PSODOSUT
- End DoDot:1
- KILL PSODAILY
- if PSOCPXC&(PSOCPXG=PSOCPXB)
- SET PSOCPXH=1
- +3 SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if '$GET(PSOCPXRR(PSOCPXG))&(PSOCPXB>1)
- DO PSOORI
- DO SUB^PSODOSUT
- Begin DoDot:1
- +4 IF $GET(PSOCPXRR(PSOCPXG))&$PIECE(PSODLNN1,";",5)'=""
- KILL PSODAILY
- +5 IF PSODLPL="2_RANGE"
- IF '$GET(PSODAILY)
- DO DAILY^PSODOSUT
- IF PSOCPXG'=PSOCPXB
- KILL PSODAILY
- +6 IF PSODLPL="1_SINGLE_RANGE"
- IF '$GET(PSODAILY)
- DO DAILY^PSODOSUT
- IF PSOCPXG'=PSOCPXB
- KILL PSODAILY
- +7 DO HD
- if $GET(PSODLQTC)
- QUIT
- DO WRITMSG
- DO HD
- if $GET(PSODLQTC)
- QUIT
- End DoDot:1
- +8 QUIT
- +9 ;
- MSGC ;write dosing message for edits or display during complex dose entry
- +1 if 'PSODLQT&(PSOCPXC)&(PSODLESM)
- QUIT
- IF PSOCPXF&(PSOCPXC)
- KILL PSODAILY
- +2 if PSOCPXC
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +3 IF 'PSOCPXF&(PSOCPXC)
- SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- Begin DoDot:1
- +4 if $GET(PSORENWD)&(PSOCPXB<4)
- QUIT
- DO SUMM^PSODOSUT
- End DoDot:1
- KILL PSODAILY
- if PSOCPXC&(PSOCPXG=PSOCPXB)
- SET PSOCPXH=1
- +5 IF PSOCPXC
- SET PSOCPXG=$PIECE(PSODLNN1,";",4)
- DO HD
- if $GET(PSODLQTC)
- QUIT
- Begin DoDot:1
- +6 IF $GET(PSOCPXRR(PSOCPXG))&$PIECE(PSODLNN1,";",5)'=""
- KILL PSODAILY
- +7 IF '$GET(PSOCPXRR(PSOCPXG))&('$GET(PSOCPXH))
- DO PSOORI
- DO SUB^PSODOSUT
- IF $GET(PSOCOPY)!($GET(PSORENW))
- if PSOCPXC&(PSOCPXG=PSOCPXB)
- SET PSOCPXH=1
- +8 IF PSODLPL="2_RANGE"&PSODLINR&'$GET(PSODAILY)
- DO DAILY^PSODOSUT
- +9 IF PSODLPL="1_SINGLE_RANGE"&PSODLINX&'$GET(PSODAILY)
- DO DAILY^PSODOSUT
- +10 DO WRITMSG
- End DoDot:1
- +11 QUIT
- +12 ;
- WRITMSG ;
- +1 if 'PSODLQT&('$GET(PSODLWW))
- WRITE !
- SET PSODLWW=0
- +2 NEW X,DIWL,DIWR,DIWF
- +3 IF +$GET(PSOINTRO)
- IF '$GET(PSOOFL)
- Begin DoDot:1
- +4 SET X=$PIECE(PSOINTRO,U,2)
- SET DIWL=1
- SET DIWR=76
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- +5 DO WRITMSG1
- +6 WRITE !
- +7 SET $PIECE(PSOINTRO,U)=0
- End DoDot:1
- +8 SET X=PSODLMSG
- SET DIWL=1
- SET DIWR=76
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- +9 DO WRITMSG1
- +10 KILL ^UTILITY($JOB,"W")
- DO HD
- if $GET(PSODLQTC)
- QUIT
- +11 IF PSODTYPE="E"
- IF 'PSODLQT
- SET PSODELNX=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1))
- IF '$PIECE($GET(PSODELNX),";",5)
- WRITE !
- +12 IF PSODTYPE="C"!(PSODTYPE="N")
- IF 'PSODLQT
- Begin DoDot:1
- +13 DO HD
- if $GET(PSODLQTC)
- QUIT
- SET PSODELNX=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1))
- IF '$PIECE($GET(PSODELNX),";",5)!($PIECE($GET(PSODELNX),";",4)'=PSOCPXG)
- WRITE !
- SET PSOLASTD(PSOLASTS)=3
- End DoDot:1
- +14 QUIT
- +15 ;
- WRITMSG1 ;
- +1 NEW PSODELXR,PSODELXF,PSOSPACE
- +2 SET PSODELXF=0
- +3 SET PSOSPACE=" "
- +4 IF +$GET(PSOINTRO)
- IF '$GET(PSOOFL)
- SET PSOSPACE=""
- +5 FOR PSODELXR=0:0
- SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
- if 'PSODELXR
- QUIT
- Begin DoDot:1
- +6 DO HD
- if $GET(PSODLQTC)
- QUIT
- if PSODELXF&('PSODLQT)
- WRITE !
- if 'PSODLQT
- WRITE PSOSPACE_$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
- SET (PSODLFLG,PSODELXF,PSONFRNF,PSOWMSG,PSODLEXR)=1
- End DoDot:1
- +7 IF $GET(PSODLFLG)&($GET(PSOCPXC))&($GET(PSOCPXB)>3)!(PSODTYPE="C"&(PSOCPXB>3))
- WRITE !
- +8 QUIT
- +9 ;
- WRTINTRO ;
- +1 NEW PSODELXR
- +2 FOR PSODELXR=0:0
- SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
- if 'PSODELXR!($GET(PSODLQTC))
- QUIT
- Begin DoDot:1
- +3 DO HD
- if $GET(PSODLQTC)
- QUIT
- WRITE $GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
- +4 IF PSODLPL'="3_GENERAL"
- WRITE !
- +5 SET $PIECE(PSOINTRO,U)=0
- End DoDot:1
- +6 QUIT
- +7 ;
- GENERAL ;general dosing range information
- +1 NEW PSODLERC,PSODLP2
- +2 IF +$GET(PSOINTRO)
- Begin DoDot:1
- +3 SET X=$PIECE(PSOINTRO,U,2)
- SET DIWL=4
- SET DIWR=76
- KILL ^UTILITY($JOB,"W")
- DO ^DIWP
- +4 DO WRTINTRO
- End DoDot:1
- +5 FOR PSODLP2=0:0
- SET PSODLP2=$ORDER(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1,PSODLP2))
- if 'PSODLP2!($GET(PSORX("DFLG")))
- QUIT
- Begin DoDot:1
- +6 SET PSODLERC=""
- SET PSODLERC=$GET(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE",PSODLPL,PSODLP1,PSODLP2))
- +7 if PSODLERC=""
- QUIT
- +8 DO HD
- if $GET(PSODLQTC)
- QUIT
- +9 ;I 'PSODLQT,'$G(PSOEDIT) W !
- +10 NEW X,DIWL,DIWR,DIWF,DIWL,PSODELXR,PSODELXF
- SET PSODLEXR=1
- +11 SET DIWL=4
- SET DIWR=76
- KILL ^UTILITY($JOB,"W")
- +12 SET X=PSODLERC
- DO ^DIWP
- +13 SET PSODELXF=0
- FOR PSODELXR=0:0
- SET PSODELXR=$ORDER(^UTILITY($JOB,"W",DIWL,PSODELXR))
- if 'PSODELXR
- QUIT
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if PSODELXF&('PSODLQT)
- WRITE !
- DO HD
- if $GET(PSODLQTC)
- QUIT
- if 'PSODLQT
- WRITE " "_$GET(^UTILITY($JOB,"W",DIWL,PSODELXR,0))
- SET (PSODELXF,PSODLERZ,PSONFRNF)=1
- +14 SET PSOLASTD(PSOLASTS)=3
- +15 IF '$DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE"))
- IF '$DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","2_RANGE"))
- IF '$DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE_RANGE"))
- Begin DoDot:2
- +16 IF +$GET(PSOEXCPT)!(+$GET(PSOERROR))
- SET PSOGENF=1
- End DoDot:2
- +17 KILL ^UTILITY($JOB,"W")
- +18 WRITE !
- End DoDot:1
- +19 QUIT
- +20 ;
- HD ;
- +1 if '$GET(PSODLQT)
- SET PSODLQT=""
- +2 IF PSODLQT!(($Y+3)<IOSL)!($GET(PSORX("DFLG")))
- QUIT
- +3 if $GET(PSORENWD)
- WRITE !
- HD2 ;
- +1 NEW DIR,DTOUT,DUOUT,DIRUT,DIROUT,X,Y
- +2 KILL DIR,Y
- SET DIR(0)="E"
- SET DIR("A")="Press Return to continue,'^' to exit"
- DO ^DIR
- KILL DIR
- +3 ;user ^'s
- IF $GET(PSOCPXC)&($DATA(DIRUT)!($DATA(DUOUT)))
- SET PSODLQTC=1
- WRITE @IOF
- WRITE !
- QUIT
- +4 IF 'Y!($DATA(DTOUT))!($DATA(DUOUT))!($GET(DIRUT))
- SET PSODLQT=1
- SET PSORX("DFLG")=1
- QUIT
- +5 WRITE @IOF
- WRITE !
- +6 SET PSOOFL=""
- if $GET(PSODELXR)
- DO PSOORI
- if $GET(PSOOFL)
- WRITE !
- +7 QUIT
- +8 ;
- PSOORI ;**writes per orifice intro text to the screen for dosing check summary**
- +1 IF +$GET(PSOINTRO)
- IF '$GET(PSOOFL)
- Begin DoDot:1
- +2 WRITE ?3,$PIECE(PSOINTRO,U,2),!
- +3 SET $PIECE(PSOINTRO,U)=0
- SET PSOOFL=1
- End DoDot:1
- +4 QUIT
- +5 ;
- SETV ; Set variables indicating what messages exist
- +1 SET (PSODMESE,PSODMESX,PSODMESG,PSODMEST,PSODMESH,PSODMESM)=0
- +2 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"ERROR"))
- SET PSODMESE=1
- +3 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"EXCEPTIONS"))
- SET PSODMESX=1
- +4 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE"))
- SET PSODMESM=1
- +5 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","3_GENERAL"))
- SET PSODMESG=1
- +6 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","4_TRAIL"))
- SET PSODMEST=1
- +7 Begin DoDot:1
- +8 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE"))
- SET PSODMESH=1
- QUIT
- +9 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","2_RANGE"))
- SET PSODMESH=1
- QUIT
- +10 IF $DATA(^TMP($JOB,"PSOPDOSN","OUT",PSODSEQ,PSODLNN1,"MESSAGE","1_SINGLE_RANGE"))
- SET PSODMESH=1
- End DoDot:1
- +11 QUIT