PSJDOSE ;BIR/MV - POSSIBLE DOSES UTILITY ; 1/6/20 11:08am
;;5.0;INPATIENT MEDICATIONS ;**50,65,106,111,216,264,328,338,398,449**;16 DEC 97;Build 18
;
; Reference to ^PSSORPH is supported by DBIA #3234.
;
;PSJDSFLG: Set to 1 if Dose and DD are not compatible
;PSJDSSEL: The selected dose in format:
; Dosage Order^DD IEN^DUPD/BCMA DUPD^1(if BCMA DUPD exist
;PSJDSUPD: Set to 1 if need to prompt for the Units Per Dose
;
EDITDOSE ;Editing Dosage Ordered for active order
;*Need to set PSJDSFLG to null when call EDITDOSE.
NEW PSGOER1,PSJDD,PSJDSUPD,PSJDSSEL,PSJX,Y
;Offer the possible doses from the only one or 1st DD
S PSJX=$O(^PS(53.45,PSJSYSP,2,0)) S PSJDD=+$G(^(+PSJX,0))
D DOSE(PSJDD)
D DOSECHK
I +PSJDSFLG D
. W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
. D PAUSE^VALM1
S PSGOEE=2
Q
GETDOSE(PSJDD) ;Dosage Order
NEW PSJDSSEL,PSJDSUPD
D DOSE(PSJDD)
Q:'$D(PSJDSSEL)
D:+$G(PSJDSUPD) DUPD
D:'+$G(PSJDSUPD) SETDUPD($P(PSJDSSEL,U,3))
D DOSECHK
I +$G(PSJDSFLG) D
. W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
Q
;
SETVAR ;
S PSJDOSE("WARN")="WARNING: Dosage Ordered and Dispense Units do not match."
S PSJDOSE("WARN1")=" Please verify Dosage."
Q
;
SETVAR0 ;
S PSJDOSE0("WARN")="WARNING: Units Per Dose of 0 can still be administered using BCMA."
S PSJDOSE0("WARN1")=" If this is NOT to be given, enter an inactive date or"
S PSJDOSE0("WARN2")=" delete the dispense drug."
Q
;
DOSE(PSJDD) ;Prompt for Dosage Ordered
;PSJDD: Dispense drug IEN
;
NEW DA,DR,DIR,DTOUT,DUOUT,DIRUT,PSJDL,PSJX,PSJPIECE,PSJCONT
D SETVAR
D DOSE^PSSORPH(.PSJDOX,+PSJDD,"U")
I '$D(PSJDOX) S PSJDOX(1)=-1
S PSJPIECE=$S($P(PSJDOX(1),U,11)]"":11,1:3)
I PSJPIECE=3 S:$S($P(PSJDOX(1),U,3)="":1,1:$P(PSJDOX(1),U)=-1) $P(PSJDOX(1),U)=-1
AGAIN ;Prompt for dosage order again
S PSJX=0
NEW DIR
W:($P(PSJDOX(1),U)'=-1) !!,"Available Dosage(s)"
F PSJDL=0:0 S PSJDL=$O(PSJDOX(PSJDL)) Q:$S('PSJDL:1,$G(DUOUT):1,1:+PSJDOX(PSJDL)=-1) D
. S PSJX=PSJX+1
. W !?4,$J(PSJX,3),". ",$P(PSJDOX(PSJDL),U,PSJPIECE)
. I '(PSJX#16) S DIR(0)="E" D ^DIR
W !
K DIR S DIR(0)="F^1:60" ;*216 - No null dosage
S DIR("A")=$S(+PSJX:"Select from list of Available Dosages or Enter Free Text Dose",1:"DOSAGE ORDERED")
S:$G(PSGDO)]"" DIR("B")=PSGDO
S DIR("?")="^D ENHLP^PSGOEM(53.1,109)" D ^DIR
S PSJY=$$UP^XLFSTR(Y)
;
I $S($D(DTOUT):1,$D(DUOUT):1,$D(DIRUT):1,1:0) S PSGOROE1=1 Q
;
;* If select for the presented list (possible and local doses)
I $D(PSJDOX(PSJY)) D G:PSJCONT=0 AGAIN S:PSJCONT="^" PSGOROE1=1 Q
. NEW X S X=$P(PSJDOX(PSJY),U,PSJPIECE)
. W " ",X
. S PSJCONT=$$CONT(X)
. I PSJCONT=0!(PSJCONT="^") Q
. D SELDOSE(PSJY,PSJDD)
;
;* Entered a numeric and choices are not local pos dose
I PSJY?.N!(PSJY?.N1".".N),(PSJPIECE'=3) D G:PSJCONT=0 AGAIN S:PSJCONT="^" PSGOROE1=1 Q
. S PSJCONT=0
. Q:$L(PSJY)>15
. D DOSE^PSSORPH(.PSJDOX,+PSJDD,"U",,PSJY/+$P(PSJDOX(1),U,5))
. S PSJCONT=$$CONT($P(PSJDOX(1),U,11)) I PSJCONT="^" Q
. I 'PSJCONT D DOSE^PSSORPH(.PSJDOX,+PSJDD,"U") Q
. D SELDOSE(1,PSJDD)
;
;* Can't accept just a numeric value
I PSJY?.N!(PSJY?.N1".".N) D ENHLP^PSGOEM(53.1,109) G AGAIN
;
;* Free text
I $E(PSJY)=" " G AGAIN
S PSJCONT=$$CONT(PSJY) I PSJCONT="^" S PSGOROE1=1 Q
I PSJCONT=0 G AGAIN
K PSJDSSEL
F X=0:0 S X=$O(PSJDOX(X)) Q:'X S PSJXDOSE=$P(PSJDOX(X),U,PSJPIECE) I PSJY=PSJXDOSE D SELDOSE(X,PSJDD) Q
I '$D(PSJDSSEL),($G(PSJY)]"") S PSJDSSEL=PSJY_U_+PSJDD_U_1,PSGDO=PSJY,PSJDSUPD=1
Q
;
SELDOSE(X,PSJDD) ;
S X=PSJDOX(X)
S PSGDO=$P(X,U,PSJPIECE)
S:$P(X,U)'=-1 PSJDOSE("DO")=$P(X,U,1,2)
S PSJDSSEL=$P(X,U,PSJPIECE)_U_PSJDD
I +$P(X,U,12) S $P(PSJDSSEL,U,3)=$P(X,U,12)_U_1 Q
S $P(PSJDSSEL,U,3)=$S(PSJPIECE=11:$P(X,U,3),1:1)
Q
CONT(X) ;Ask if user accepting the dose
NEW DIR,DIRUT,DIROUT,Y
W ! K DIR,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="You entered "_X_" is this correct",DIR("B")="Yes"
D ^DIR I $D(DIRUT)!$D(DIROUT) Q "^"
K DUOUT
Q +Y
;
DUPD ;
NEW PSJX,X
S PSGUD=1
W !,"UNITS PER DOSE: "_PSGUD_"// " R X:DTIME W " ",X I X="^"!'$T S PSGOROE1=1 Q
S:X="" X=1
I X="@",'PSGUD W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.11,.02) G DUPD
I X?1."?" D ENHLP^PSGOEM(53.11,.02) G DUPD
I X?1.2N1"/"1.2N S X=+$J(+X/$P(X,"/",2),0,2) W " ("_$E("0",X<1)_X_")"
I $S($L(X)>12:1,X'=+X:1,X>50:1,X<0:1,1:X?.N1"."5.N) W $C(7)," ??" S X="?" D ENHLP^PSGOEM(53.11,.02) G DUPD
S $P(PSJDSSEL,U,3)=X
D SETDUPD(X)
Q
SETDUPD(X) ;
S PSGUD=X,X=$S(PSJDSSEL]"":$P(PSJDSSEL,U,2),1:0)
S PSJX=$O(^PS(53.45,PSJSYSP,2,"B",X,0))
S PSGUD=+$FN(PSGUD,"",4) S:$E(PSGUD)="." PSGUD="0"_PSGUD
S $P(^PS(53.45,PSJSYSP,2,+PSJX,0),U,2)=PSGUD
Q
EDITDD ;Editing DDs
NEW DA,DR,DIE
S DIE="^PS(53.45,",DA=PSJSYSP,DR=2,DR(2,53.4502)=".02//1" D ^DIE
I '$O(^PS(53.45,PSJSYSP,2,0)) W $C(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!"
Q
DOSECHK ;
K PSJDSFLG,PSJDSFLG0 S (PSJDSFLG,PSJDSFLG0)=0
Q:'$P(PSJSYSU,";",4)
Q:$G(PSGDO)=""
NEW PSJX,PSJXDD,PSJCNT S PSJCNT=0
;*216 Be sure PSJDT is set
I '$G(PSJDT) N X,% D NOW^%DTC S PSJDT=X
F PSJX=0:0 S PSJX=$O(^PS(53.45,PSJSYSP,2,PSJX)) Q:'PSJX D
. S PSJXDD=$G(^PS(53.45,PSJSYSP,2,PSJX,0)) Q:PSJXDD=""
. S:$P(PSJXDD,U,2)="" $P(^PS(53.45,PSJSYSP,2,PSJX,0),U,2)=1
. ;*216 Don't count inactive Disp. Drug
. I $P(PSJXDD,U,3)'="",$P(PSJXDD,U,3)'>PSJDT Q
. S PSJCNT=PSJCNT+1
D DOSECHK1
;PSJ*5*449 call for 0 units per dose warning check
D DOSECHK0
Q
DOSECHK1 ;
NEW PSJX,PSJXDD,PSJXUNIT,PSJUNIT,PSJXFLG,PSJTOT,PSJDRGDOSE,PSJUNITNM,PSJDRGUD,CNT
S CNT=0
;*216 Be sure PSJDT is set
I '$G(PSJDT) N X,% D NOW^%DTC S PSJDT=X
S PSJUNIT=$P(PSGDO,+PSGDO,2,$L(PSGDO,+PSGDO))
S (PSJDSFLG,PSJXFLG,PSJTOT,PSJDSFLG0)=0
S PSJX=0 F S PSJX=$O(^PS(53.45,PSJSYSP,2,PSJX)) Q:'PSJX!PSJDSFLG!PSJXFLG D
. S PSJXDD=$G(^PS(53.45,PSJSYSP,2,PSJX,0))
. S PSJXDUP=$S(+$P(PSJXDD,U,2):$P(PSJXDD,U,2),1:1)
. ;*216 Don't count inactive Disp. Drug
. I $P(PSJXDD,U,3)'="",$P(PSJXDD,U,3)'>PSJDT Q
. D DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U")
. I $S('$D(PSJXDOX):1,$P(PSJXDOX(1),U)="":1,1:+PSJXDOX(1)=-1) S PSJXFLG=1 Q
. S PSJXUNIT=""
. S:PSJUNIT["/" PSJXUNIT=PSJUNIT
. I PSJUNIT'["/" F X=1:1:$L(PSJUNIT) I $E(PSJUNIT,X)'?.N&($E(PSJUNIT,X)'?1" ") S PSJXUNIT=PSJXUNIT_$E(PSJUNIT,X)
. I PSJCNT=1 D ONEDD Q:'PSJDSFLG
. D BCMAUPD(PSJXDD),DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U",,PSJXDUP)
. I PSJCNT=1 D ONEDD Q
. S PSJTOT=+PSJXDOX(1)+$G(PSJTOT)
. ;*PSJ*5*264 - Data for POINTTOSURFACE calculation
. S CNT=CNT+1,PSJDRGDOSE(CNT)=+$P(PSJXDOX(1),U,5),PSJUNITNM(CNT)=$P(PSJXDOX(1),U,2),PSJDRGUD(CNT)=+$P(PSJXDOX(1),U,3)
I PSJCNT>1,(PSJTOT'=+PSGDO) D
. N UNITCNT,UNITERR
. S PSJDSFLG=1
. F UNITCNT=2:1:CNT I PSJUNITNM(UNITCNT)'=PSJUNITNM(1) S UNITERR=1 Q
. I '$G(UNITERR),$$PTPLANE(.PSJDRGUD,.PSJDRGDOSE,+PSGDO)'=-1,$$PTPLANE(.PSJDRGUD,.PSJDRGDOSE,+PSGDO)<($$SQRT^XLFMTH(CNT)/100) S PSJDSFLG=0
Q
DOSECHK0 ;
;PSJ*5.0*449 Warning message for Units per Dose = 0
F PSJX=0:0 S PSJX=$O(^PS(53.45,PSJSYSP,2,PSJX)) Q:'PSJX!PSJDSFLG0 D
. S PSJXDD=$G(^PS(53.45,PSJSYSP,2,PSJX,0)) Q:PSJXDD=""
. I $P(PSJXDD,U,2)'=0 Q
. I $P(PSJXDD,U,3)'="",($P(PSJXDD,U,3)'>DT) Q
. S PSJDSFLG0=1
Q
;
ONEDD ;
NEW X S PSJDSFLG=1
F X=0:0 S X=$O(PSJXDOX(X)) Q:'X!'PSJDSFLG D
. I +PSJXDOX(X)'=+PSGDO,(PSJXUNIT=$P(PSJXDOX(X),U,2)),$S(+PSJXDUP=+$P(PSJXDOX(X),U,3):1,1:PSJXDUP=$P(PSJXDOX(X),U,12)) D Q:PSJDSFLG
..; REMOVED THE ROUNDING FUNCTION FOR 398 - PER SUMPM
..; N CHK,DGTS S CHK=+PSGDO/$P(PSJXDOX(X),U,5) S DGTS=$L($P(PSJXDUP,".",2)) S CHK=+$FN(CHK,"",DGTS) I +CHK=+PSJXDUP S PSJDSFLG=0
.. N CHK,DGTS S CHK=+PSGDO/$P(PSJXDOX(X),U,5) S DGTS=$L($P(PSJXDUP,".",2)) I +CHK=+PSJXDUP S PSJDSFLG=0
. I +PSJXDOX(X)=+PSGDO,$TR($P(PSJXDOX(X),U,11)," ")=$TR(PSGDO," "),$S(+PSJXDUP=+$P(PSJXDOX(X),U,3):1,1:PSJXDUP=$P(PSJXDOX(X),U,12)) S PSJDSFLG=0
Q
PTPLANE(P,X,C) ;Find the distance from a point to a line/plane
;P - array containing coordinates of point
;X - array representing normal vector defining the line/plane
;C - constant representing point defining the line/plane
;*PSJ*5*264 - PTPLANE added
;
N N,CNT,NUM,DEN
Q:'$D(P)!'$D(X)!'$D(C) -1
S N=0,CNT=0,NUM=0,DEN=0
F S CNT=$O(P(CNT)) Q:'CNT S N=N+1
F CNT=1:1:N S NUM=P(CNT)*X(CNT)+NUM
S NUM=$$ABS^XLFMTH(NUM-C)
F CNT=1:1:N S DEN=X(CNT)**2+DEN
S DEN=$$SQRT^XLFMTH(DEN)
Q $S(DEN=0:-1,1:NUM/DEN)
BCMAUPD(PSJDD) ;
NEW PSJCNT
K PSJBCMA
F X=0:0 S X=$O(PSJXDOX(X)) Q:'X D
. Q:'+$P(PSJXDOX(X),U,12)
. S PSJCNT=+$G(PSJCNT)+1
. S PSJBCMA(+PSJDD,$P(PSJXDOX(X),U,12),PSJCNT)=$P(PSJXDOX(X),U,1,2)
Q
DSPWARN ;
NEW PSJDOSE
D SETVAR
W !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
;PSJ*5*449 MOVE PAUSE TO PSGOE82
;D PAUSE^VALM1
Q
;
DSPWARN0 ;
NEW PSJDOSE0
D SETVAR0
W !!,PSJDOSE0("WARN"),!,PSJDOSE0("WARN1"),!,PSJDOSE0("WARN2"),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJDOSE 8969 printed Sep 23, 2025@19:42:50 Page 2
PSJDOSE ;BIR/MV - POSSIBLE DOSES UTILITY ; 1/6/20 11:08am
+1 ;;5.0;INPATIENT MEDICATIONS ;**50,65,106,111,216,264,328,338,398,449**;16 DEC 97;Build 18
+2 ;
+3 ; Reference to ^PSSORPH is supported by DBIA #3234.
+4 ;
+5 ;PSJDSFLG: Set to 1 if Dose and DD are not compatible
+6 ;PSJDSSEL: The selected dose in format:
+7 ; Dosage Order^DD IEN^DUPD/BCMA DUPD^1(if BCMA DUPD exist
+8 ;PSJDSUPD: Set to 1 if need to prompt for the Units Per Dose
+9 ;
EDITDOSE ;Editing Dosage Ordered for active order
+1 ;*Need to set PSJDSFLG to null when call EDITDOSE.
+2 NEW PSGOER1,PSJDD,PSJDSUPD,PSJDSSEL,PSJX,Y
+3 ;Offer the possible doses from the only one or 1st DD
+4 SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,0))
SET PSJDD=+$GET(^(+PSJX,0))
+5 DO DOSE(PSJDD)
+6 DO DOSECHK
+7 IF +PSJDSFLG
Begin DoDot:1
+8 WRITE !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
+9 DO PAUSE^VALM1
End DoDot:1
+10 SET PSGOEE=2
+11 QUIT
GETDOSE(PSJDD) ;Dosage Order
+1 NEW PSJDSSEL,PSJDSUPD
+2 DO DOSE(PSJDD)
+3 if '$DATA(PSJDSSEL)
QUIT
+4 if +$GET(PSJDSUPD)
DO DUPD
+5 if '+$GET(PSJDSUPD)
DO SETDUPD($PIECE(PSJDSSEL,U,3))
+6 DO DOSECHK
+7 IF +$GET(PSJDSFLG)
Begin DoDot:1
+8 WRITE !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
End DoDot:1
+9 QUIT
+10 ;
SETVAR ;
+1 SET PSJDOSE("WARN")="WARNING: Dosage Ordered and Dispense Units do not match."
+2 SET PSJDOSE("WARN1")=" Please verify Dosage."
+3 QUIT
+4 ;
SETVAR0 ;
+1 SET PSJDOSE0("WARN")="WARNING: Units Per Dose of 0 can still be administered using BCMA."
+2 SET PSJDOSE0("WARN1")=" If this is NOT to be given, enter an inactive date or"
+3 SET PSJDOSE0("WARN2")=" delete the dispense drug."
+4 QUIT
+5 ;
DOSE(PSJDD) ;Prompt for Dosage Ordered
+1 ;PSJDD: Dispense drug IEN
+2 ;
+3 NEW DA,DR,DIR,DTOUT,DUOUT,DIRUT,PSJDL,PSJX,PSJPIECE,PSJCONT
+4 DO SETVAR
+5 DO DOSE^PSSORPH(.PSJDOX,+PSJDD,"U")
+6 IF '$DATA(PSJDOX)
SET PSJDOX(1)=-1
+7 SET PSJPIECE=$SELECT($PIECE(PSJDOX(1),U,11)]"":11,1:3)
+8 IF PSJPIECE=3
if $SELECT($PIECE(PSJDOX(1),U,3)=""
SET $PIECE(PSJDOX(1),U)=-1
AGAIN ;Prompt for dosage order again
+1 SET PSJX=0
+2 NEW DIR
+3 if ($PIECE(PSJDOX(1),U)'=-1)
WRITE !!,"Available Dosage(s)"
+4 FOR PSJDL=0:0
SET PSJDL=$ORDER(PSJDOX(PSJDL))
if $SELECT('PSJDL
QUIT
Begin DoDot:1
+5 SET PSJX=PSJX+1
+6 WRITE !?4,$JUSTIFY(PSJX,3),". ",$PIECE(PSJDOX(PSJDL),U,PSJPIECE)
+7 IF '(PSJX#16)
SET DIR(0)="E"
DO ^DIR
End DoDot:1
+8 WRITE !
+9 ;*216 - No null dosage
KILL DIR
SET DIR(0)="F^1:60"
+10 SET DIR("A")=$SELECT(+PSJX:"Select from list of Available Dosages or Enter Free Text Dose",1:"DOSAGE ORDERED")
+11 if $GET(PSGDO)]""
SET DIR("B")=PSGDO
+12 SET DIR("?")="^D ENHLP^PSGOEM(53.1,109)"
DO ^DIR
+13 SET PSJY=$$UP^XLFSTR(Y)
+14 ;
+15 IF $SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIRUT):1,1:0)
SET PSGOROE1=1
QUIT
+16 ;
+17 ;* If select for the presented list (possible and local doses)
+18 IF $DATA(PSJDOX(PSJY))
Begin DoDot:1
+19 NEW X
SET X=$PIECE(PSJDOX(PSJY),U,PSJPIECE)
+20 WRITE " ",X
+21 SET PSJCONT=$$CONT(X)
+22 IF PSJCONT=0!(PSJCONT="^")
QUIT
+23 DO SELDOSE(PSJY,PSJDD)
End DoDot:1
if PSJCONT=0
GOTO AGAIN
if PSJCONT="^"
SET PSGOROE1=1
QUIT
+24 ;
+25 ;* Entered a numeric and choices are not local pos dose
+26 IF PSJY?.N!(PSJY?.N1".".N)
IF (PSJPIECE'=3)
Begin DoDot:1
+27 SET PSJCONT=0
+28 if $LENGTH(PSJY)>15
QUIT
+29 DO DOSE^PSSORPH(.PSJDOX,+PSJDD,"U",,PSJY/+$PIECE(PSJDOX(1),U,5))
+30 SET PSJCONT=$$CONT($PIECE(PSJDOX(1),U,11))
IF PSJCONT="^"
QUIT
+31 IF 'PSJCONT
DO DOSE^PSSORPH(.PSJDOX,+PSJDD,"U")
QUIT
+32 DO SELDOSE(1,PSJDD)
End DoDot:1
if PSJCONT=0
GOTO AGAIN
if PSJCONT="^"
SET PSGOROE1=1
QUIT
+33 ;
+34 ;* Can't accept just a numeric value
+35 IF PSJY?.N!(PSJY?.N1".".N)
DO ENHLP^PSGOEM(53.1,109)
GOTO AGAIN
+36 ;
+37 ;* Free text
+38 IF $EXTRACT(PSJY)=" "
GOTO AGAIN
+39 SET PSJCONT=$$CONT(PSJY)
IF PSJCONT="^"
SET PSGOROE1=1
QUIT
+40 IF PSJCONT=0
GOTO AGAIN
+41 KILL PSJDSSEL
+42 FOR X=0:0
SET X=$ORDER(PSJDOX(X))
if 'X
QUIT
SET PSJXDOSE=$PIECE(PSJDOX(X),U,PSJPIECE)
IF PSJY=PSJXDOSE
DO SELDOSE(X,PSJDD)
QUIT
+43 IF '$DATA(PSJDSSEL)
IF ($GET(PSJY)]"")
SET PSJDSSEL=PSJY_U_+PSJDD_U_1
SET PSGDO=PSJY
SET PSJDSUPD=1
+44 QUIT
+45 ;
SELDOSE(X,PSJDD) ;
+1 SET X=PSJDOX(X)
+2 SET PSGDO=$PIECE(X,U,PSJPIECE)
+3 if $PIECE(X,U)'=-1
SET PSJDOSE("DO")=$PIECE(X,U,1,2)
+4 SET PSJDSSEL=$PIECE(X,U,PSJPIECE)_U_PSJDD
+5 IF +$PIECE(X,U,12)
SET $PIECE(PSJDSSEL,U,3)=$PIECE(X,U,12)_U_1
QUIT
+6 SET $PIECE(PSJDSSEL,U,3)=$SELECT(PSJPIECE=11:$PIECE(X,U,3),1:1)
+7 QUIT
CONT(X) ;Ask if user accepting the dose
+1 NEW DIR,DIRUT,DIROUT,Y
+2 WRITE !
KILL DIR,DIRUT,DUOUT
+3 SET DIR(0)="Y"
SET DIR("A")="You entered "_X_" is this correct"
SET DIR("B")="Yes"
+4 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
QUIT "^"
+5 KILL DUOUT
+6 QUIT +Y
+7 ;
DUPD ;
+1 NEW PSJX,X
+2 SET PSGUD=1
+3 WRITE !,"UNITS PER DOSE: "_PSGUD_"// "
READ X:DTIME
WRITE " ",X
IF X="^"!'$TEST
SET PSGOROE1=1
QUIT
+4 if X=""
SET X=1
+5 IF X="@"
IF 'PSGUD
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.11,.02)
GOTO DUPD
+6 IF X?1."?"
DO ENHLP^PSGOEM(53.11,.02)
GOTO DUPD
+7 IF X?1.2N1"/"1.2N
SET X=+$JUSTIFY(+X/$PIECE(X,"/",2),0,2)
WRITE " ("_$EXTRACT("0",X<1)_X_")"
+8 IF $SELECT($LENGTH(X)>12:1,X'=+X:1,X>50:1,X<0:1,1:X?.N1"."5.N)
WRITE $CHAR(7)," ??"
SET X="?"
DO ENHLP^PSGOEM(53.11,.02)
GOTO DUPD
+9 SET $PIECE(PSJDSSEL,U,3)=X
+10 DO SETDUPD(X)
+11 QUIT
SETDUPD(X) ;
+1 SET PSGUD=X
SET X=$SELECT(PSJDSSEL]"":$PIECE(PSJDSSEL,U,2),1:0)
+2 SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,"B",X,0))
+3 SET PSGUD=+$FNUMBER(PSGUD,"",4)
if $EXTRACT(PSGUD)="."
SET PSGUD="0"_PSGUD
+4 SET $PIECE(^PS(53.45,PSJSYSP,2,+PSJX,0),U,2)=PSGUD
+5 QUIT
EDITDD ;Editing DDs
+1 NEW DA,DR,DIE
+2 SET DIE="^PS(53.45,"
SET DA=PSJSYSP
SET DR=2
SET DR(2,53.4502)=".02//1"
DO ^DIE
+3 IF '$ORDER(^PS(53.45,PSJSYSP,2,0))
WRITE $CHAR(7),!!,"WARNING: This order must have at least one dispense drug before pharmacy can",!?9,"verify it!"
+4 QUIT
DOSECHK ;
+1 KILL PSJDSFLG,PSJDSFLG0
SET (PSJDSFLG,PSJDSFLG0)=0
+2 if '$PIECE(PSJSYSU,";",4)
QUIT
+3 if $GET(PSGDO)=""
QUIT
+4 NEW PSJX,PSJXDD,PSJCNT
SET PSJCNT=0
+5 ;*216 Be sure PSJDT is set
+6 IF '$GET(PSJDT)
NEW X,%
DO NOW^%DTC
SET PSJDT=X
+7 FOR PSJX=0:0
SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,PSJX))
if 'PSJX
QUIT
Begin DoDot:1
+8 SET PSJXDD=$GET(^PS(53.45,PSJSYSP,2,PSJX,0))
if PSJXDD=""
QUIT
+9 if $PIECE(PSJXDD,U,2)=""
SET $PIECE(^PS(53.45,PSJSYSP,2,PSJX,0),U,2)=1
+10 ;*216 Don't count inactive Disp. Drug
+11 IF $PIECE(PSJXDD,U,3)'=""
IF $PIECE(PSJXDD,U,3)'>PSJDT
QUIT
+12 SET PSJCNT=PSJCNT+1
End DoDot:1
+13 DO DOSECHK1
+14 ;PSJ*5*449 call for 0 units per dose warning check
+15 DO DOSECHK0
+16 QUIT
DOSECHK1 ;
+1 NEW PSJX,PSJXDD,PSJXUNIT,PSJUNIT,PSJXFLG,PSJTOT,PSJDRGDOSE,PSJUNITNM,PSJDRGUD,CNT
+2 SET CNT=0
+3 ;*216 Be sure PSJDT is set
+4 IF '$GET(PSJDT)
NEW X,%
DO NOW^%DTC
SET PSJDT=X
+5 SET PSJUNIT=$PIECE(PSGDO,+PSGDO,2,$LENGTH(PSGDO,+PSGDO))
+6 SET (PSJDSFLG,PSJXFLG,PSJTOT,PSJDSFLG0)=0
+7 SET PSJX=0
FOR
SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,PSJX))
if 'PSJX!PSJDSFLG!PSJXFLG
QUIT
Begin DoDot:1
+8 SET PSJXDD=$GET(^PS(53.45,PSJSYSP,2,PSJX,0))
+9 SET PSJXDUP=$SELECT(+$PIECE(PSJXDD,U,2):$PIECE(PSJXDD,U,2),1:1)
+10 ;*216 Don't count inactive Disp. Drug
+11 IF $PIECE(PSJXDD,U,3)'=""
IF $PIECE(PSJXDD,U,3)'>PSJDT
QUIT
+12 DO DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U")
+13 IF $SELECT('$DATA(PSJXDOX):1,$PIECE(PSJXDOX(1),U)="":1,1:+PSJXDOX(1)=-1)
SET PSJXFLG=1
QUIT
+14 SET PSJXUNIT=""
+15 if PSJUNIT["/"
SET PSJXUNIT=PSJUNIT
+16 IF PSJUNIT'["/"
FOR X=1:1:$LENGTH(PSJUNIT)
IF $EXTRACT(PSJUNIT,X)'?.N&($EXTRACT(PSJUNIT,X)'?1" ")
SET PSJXUNIT=PSJXUNIT_$EXTRACT(PSJUNIT,X)
+17 IF PSJCNT=1
DO ONEDD
if 'PSJDSFLG
QUIT
+18 DO BCMAUPD(PSJXDD)
DO DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U",,PSJXDUP)
+19 IF PSJCNT=1
DO ONEDD
QUIT
+20 SET PSJTOT=+PSJXDOX(1)+$GET(PSJTOT)
+21 ;*PSJ*5*264 - Data for POINTTOSURFACE calculation
+22 SET CNT=CNT+1
SET PSJDRGDOSE(CNT)=+$PIECE(PSJXDOX(1),U,5)
SET PSJUNITNM(CNT)=$PIECE(PSJXDOX(1),U,2)
SET PSJDRGUD(CNT)=+$PIECE(PSJXDOX(1),U,3)
End DoDot:1
+23 IF PSJCNT>1
IF (PSJTOT'=+PSGDO)
Begin DoDot:1
+24 NEW UNITCNT,UNITERR
+25 SET PSJDSFLG=1
+26 FOR UNITCNT=2:1:CNT
IF PSJUNITNM(UNITCNT)'=PSJUNITNM(1)
SET UNITERR=1
QUIT
+27 IF '$GET(UNITERR)
IF $$PTPLANE(.PSJDRGUD,.PSJDRGDOSE,+PSGDO)'=-1
IF $$PTPLANE(.PSJDRGUD,.PSJDRGDOSE,+PSGDO)<($$SQRT^XLFMTH(CNT)/100)
SET PSJDSFLG=0
End DoDot:1
+28 QUIT
DOSECHK0 ;
+1 ;PSJ*5.0*449 Warning message for Units per Dose = 0
+2 FOR PSJX=0:0
SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,PSJX))
if 'PSJX!PSJDSFLG0
QUIT
Begin DoDot:1
+3 SET PSJXDD=$GET(^PS(53.45,PSJSYSP,2,PSJX,0))
if PSJXDD=""
QUIT
+4 IF $PIECE(PSJXDD,U,2)'=0
QUIT
+5 IF $PIECE(PSJXDD,U,3)'=""
IF ($PIECE(PSJXDD,U,3)'>DT)
QUIT
+6 SET PSJDSFLG0=1
End DoDot:1
+7 QUIT
+8 ;
ONEDD ;
+1 NEW X
SET PSJDSFLG=1
+2 FOR X=0:0
SET X=$ORDER(PSJXDOX(X))
if 'X!'PSJDSFLG
QUIT
Begin DoDot:1
+3 IF +PSJXDOX(X)'=+PSGDO
IF (PSJXUNIT=$PIECE(PSJXDOX(X),U,2))
IF $SELECT(+PSJXDUP=+$PIECE(PSJXDOX(X),U,3):1,1:PSJXDUP=$PIECE(PSJXDOX(X),U,12))
Begin DoDot:2
+4 ; REMOVED THE ROUNDING FUNCTION FOR 398 - PER SUMPM
+5 ; N CHK,DGTS S CHK=+PSGDO/$P(PSJXDOX(X),U,5) S DGTS=$L($P(PSJXDUP,".",2)) S CHK=+$FN(CHK,"",DGTS) I +CHK=+PSJXDUP S PSJDSFLG=0
+6 NEW CHK,DGTS
SET CHK=+PSGDO/$PIECE(PSJXDOX(X),U,5)
SET DGTS=$LENGTH($PIECE(PSJXDUP,".",2))
IF +CHK=+PSJXDUP
SET PSJDSFLG=0
End DoDot:2
if PSJDSFLG
QUIT
+7 IF +PSJXDOX(X)=+PSGDO
IF $TRANSLATE($PIECE(PSJXDOX(X),U,11)," ")=$TRANSLATE(PSGDO," ")
IF $SELECT(+PSJXDUP=+$PIECE(PSJXDOX(X),U,3):1,1:PSJXDUP=$PIECE(PSJXDOX(X),U,12))
SET PSJDSFLG=0
End DoDot:1
+8 QUIT
PTPLANE(P,X,C) ;Find the distance from a point to a line/plane
+1 ;P - array containing coordinates of point
+2 ;X - array representing normal vector defining the line/plane
+3 ;C - constant representing point defining the line/plane
+4 ;*PSJ*5*264 - PTPLANE added
+5 ;
+6 NEW N,CNT,NUM,DEN
+7 if '$DATA(P)!'$DATA(X)!'$DATA(C)
QUIT -1
+8 SET N=0
SET CNT=0
SET NUM=0
SET DEN=0
+9 FOR
SET CNT=$ORDER(P(CNT))
if 'CNT
QUIT
SET N=N+1
+10 FOR CNT=1:1:N
SET NUM=P(CNT)*X(CNT)+NUM
+11 SET NUM=$$ABS^XLFMTH(NUM-C)
+12 FOR CNT=1:1:N
SET DEN=X(CNT)**2+DEN
+13 SET DEN=$$SQRT^XLFMTH(DEN)
+14 QUIT $SELECT(DEN=0:-1,1:NUM/DEN)
BCMAUPD(PSJDD) ;
+1 NEW PSJCNT
+2 KILL PSJBCMA
+3 FOR X=0:0
SET X=$ORDER(PSJXDOX(X))
if 'X
QUIT
Begin DoDot:1
+4 if '+$PIECE(PSJXDOX(X),U,12)
QUIT
+5 SET PSJCNT=+$GET(PSJCNT)+1
+6 SET PSJBCMA(+PSJDD,$PIECE(PSJXDOX(X),U,12),PSJCNT)=$PIECE(PSJXDOX(X),U,1,2)
End DoDot:1
+7 QUIT
DSPWARN ;
+1 NEW PSJDOSE
+2 DO SETVAR
+3 WRITE !!,PSJDOSE("WARN"),!,PSJDOSE("WARN1"),!
+4 ;PSJ*5*449 MOVE PAUSE TO PSGOE82
+5 ;D PAUSE^VALM1
+6 QUIT
+7 ;
DSPWARN0 ;
+1 NEW PSJDOSE0
+2 DO SETVAR0
+3 WRITE !!,PSJDOSE0("WARN"),!,PSJDOSE0("WARN1"),!,PSJDOSE0("WARN2"),!
+4 QUIT
