PSJDOSE.m

PSJDOSE ;BIR/MV - POSSIBLE DOSES UTILITY ; 1/6/20 11:08am

 ;;5.0;INPATIENT MEDICATIONS ;**50,65,106,111,216,264,328,338,398**;16 DEC 97;Build 3

 ;

 ; 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

 ;

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 S PSJDSFLG=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

 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)=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

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"),!

 D PAUSE^VALM1

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSJDOSE   8192     printed  Mar 13, 2025@21:11:35                                                                                                                                                                                                     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**;16 DEC 97;Build 3

 +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       ;

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

           SET PSJDSFLG=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       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)=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 

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        DO PAUSE^VALM1

 +5        QUIT