PSJDOSE ;BIR/MV-POSSIBLE DOSES UTILITY ;16 Jan 2001 1:53 PM
;;5.0; INPATIENT MEDICATIONS ;**50,65,106,111**;16 DEC 97
;
; 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)="FO^1:60"
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=Y
;
;* Dosage Ordered entered is null
I PSJY="" S PSJDSUPD=1,PSGDO="",PSJDSSEL=U_+PSJDD_U_1 Q
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 AGAIN Q
. NEW X S X=$P(PSJDOX(PSJY),U,PSJPIECE)
. W " ",X
. S PSJCONT=$$CONT(X)
. Q:'PSJCONT
. 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 AGAIN Q
. 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 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
G:'$$CONT(PSJY) 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,Y
W ! K DIR,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="You entered "_X_" is this correct",DIR("B")="Yes"
D ^DIR
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
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
. S PSJCNT=PSJCNT+1
D DOSECHK1
Q
DOSECHK1 ;
NEW PSJX,PSJXDD,PSJXUNIT,PSJUNIT,PSJXFLG,PSJTOT
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)
. 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)
I PSJCNT>1,(PSJTOT'=+PSGDO) S PSJDSFLG=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
.. N CHK S CHK=+PSGDO/$P(PSJXDOX(X),U,5) S CHK=+$FN(CHK,"",4) S:$E(CHK)="." CHK="0"_CHK 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
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
PSJDOSE ;BIR/MV-POSSIBLE DOSES UTILITY ;16 Jan 2001 1:53 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;**50,65,106,111**;16 DEC 97
+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 KILL DIR
SET DIR(0)="FO^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=Y
+14 ;
+15 ;* Dosage Ordered entered is null
+16 IF PSJY=""
SET PSJDSUPD=1
SET PSGDO=""
SET PSJDSSEL=U_+PSJDD_U_1
QUIT
+17 IF $SELECT($DATA(DTOUT):1,$DATA(DUOUT):1,$DATA(DIRUT):1,1:0)
SET PSGOROE1=1
QUIT
+18 ;
+19 ;* If select for the presented list (possible and local doses)
+20 IF $DATA(PSJDOX(PSJY))
Begin DoDot:1
+21 NEW X
SET X=$PIECE(PSJDOX(PSJY),U,PSJPIECE)
+22 WRITE " ",X
+23 SET PSJCONT=$$CONT(X)
+24 IF 'PSJCONT
QUIT
+25 DO SELDOSE(PSJY,PSJDD)
End DoDot:1
IF 'PSJCONT
GOTO AGAIN
QUIT
+26 ;
+27 ;* Entered a numeric and choices are not local pos dose
+28 IF PSJY?.N!(PSJY?.N1".".N)
IF (PSJPIECE'=3)
Begin DoDot:1
+29 IF $LENGTH(PSJY)>15
QUIT
+30 DO DOSE^PSSORPH(.PSJDOX,+PSJDD,"U",,PSJY/+$PIECE(PSJDOX(1),U,5))
+31 SET PSJCONT=$$CONT($PIECE(PSJDOX(1),U,11))
+32 IF 'PSJCONT
DO DOSE^PSSORPH(.PSJDOX,+PSJDD,"U")
QUIT
+33 DO SELDOSE(1,PSJDD)
End DoDot:1
IF 'PSJCONT
GOTO AGAIN
QUIT
+34 ;
+35 ;* Can't accept just a numeric value
+36 IF PSJY?.N!(PSJY?.N1".".N)
DO ENHLP^PSGOEM(53.1,109)
GOTO AGAIN
+37 ;
+38 ;* Free text
+39 IF '$$CONT(PSJY)
GOTO AGAIN
+40 KILL PSJDSSEL
+41 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
+42 IF '$DATA(PSJDSSEL)
IF ($GET(PSJY)]"")
SET PSJDSSEL=PSJY_U_+PSJDD_U_1
SET PSGDO=PSJY
SET PSJDSUPD=1
+43 QUIT
+44 ;
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,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
+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 FOR PSJX=0:0
SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,PSJX))
IF 'PSJX
QUIT
Begin DoDot:1
+6 SET PSJXDD=$GET(^PS(53.45,PSJSYSP,2,PSJX,0))
IF PSJXDD=""
QUIT
+7 IF $PIECE(PSJXDD,U,2)=""
SET $PIECE(^PS(53.45,PSJSYSP,2,PSJX,0),U,2)=1
+8 SET PSJCNT=PSJCNT+1
End DoDot:1
+9 DO DOSECHK1
+10 QUIT
DOSECHK1 ;
+1 NEW PSJX,PSJXDD,PSJXUNIT,PSJUNIT,PSJXFLG,PSJTOT
+2 SET PSJUNIT=$PIECE(PSGDO,+PSGDO,2,$LENGTH(PSGDO,+PSGDO))
+3 SET (PSJDSFLG,PSJXFLG,PSJTOT)=0
+4 SET PSJX=0
FOR
SET PSJX=$ORDER(^PS(53.45,PSJSYSP,2,PSJX))
IF 'PSJX!PSJDSFLG!PSJXFLG
QUIT
Begin DoDot:1
+5 SET PSJXDD=$GET(^PS(53.45,PSJSYSP,2,PSJX,0))
+6 SET PSJXDUP=$SELECT(+$PIECE(PSJXDD,U,2):$PIECE(PSJXDD,U,2),1:1)
+7 DO DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U")
+8 IF $SELECT('$DATA(PSJXDOX):1,$PIECE(PSJXDOX(1),U)="":1,1:+PSJXDOX(1)=-1)
SET PSJXFLG=1
QUIT
+9 SET PSJXUNIT=""
+10 IF PSJUNIT["/"
SET PSJXUNIT=PSJUNIT
+11 IF PSJUNIT'["/"
FOR X=1:1:$LENGTH(PSJUNIT)
IF $EXTRACT(PSJUNIT,X)'?.N&($EXTRACT(PSJUNIT,X)'?1" ")
SET PSJXUNIT=PSJXUNIT_$EXTRACT(PSJUNIT,X)
+12 IF PSJCNT=1
DO ONEDD
IF 'PSJDSFLG
QUIT
+13 DO BCMAUPD(PSJXDD)
DO DOSE^PSSORPH(.PSJXDOX,+PSJXDD,"U",,PSJXDUP)
+14 IF PSJCNT=1
DO ONEDD
QUIT
+15 SET PSJTOT=+PSJXDOX(1)+$GET(PSJTOT)
End DoDot:1
+16 IF PSJCNT>1
IF (PSJTOT'=+PSGDO)
SET PSJDSFLG=1
+17 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 NEW CHK
SET CHK=+PSGDO/$PIECE(PSJXDOX(X),U,5)
SET CHK=+$FNUMBER(CHK,"",4)
IF $EXTRACT(CHK)="."
SET CHK="0"_CHK
IF CHK=PSJXDUP
SET PSJDSFLG=0
End DoDot:2
IF PSJDSFLG
QUIT
+5 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
+6 QUIT
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
