PSS0114 ;BIR/JLC-UPDATE ORDERABLE ITEMS WITH DEFAULT MED ROUTES ;08/28/2006
;;1.0;PHARMACY DATA MANAGEMENT;**114**;9/30/97;Build 2
;
;
N A,B,C,DF,Y,MRP,MR,OUT,IEN,OK,X
EN K DIC S DIC="^PS(50.606,",DIC(0)="AEMQ",DIC("A")="Select DOSAGE FORM: " D ^DIC K DIC Q:X=""!(X="^") I Y<0 G EN
S DF=$P(Y,"^",2)
EN1 K DIC S DIC="^PS(51.2,",DIC(0)="AEMQ",DIC("A")="Select MEDICATION ROUTE: " D ^DIC K DIC Q:X=""!(X="^") I Y<0 G EN1
W ! S MRP=$P(Y,"^"),MR=$P(Y,"^",2),(OUT,IEN)=0
F S IEN=$O(^PS(50.7,IEN)) Q:'IEN D Q:OUT
. S A=$G(^(IEN,0)) Q:$P(A,"^",6)]"" S B=$P(A,"^",2) Q:B="" S C=$P($G(^PS(50.606,B,0)),"^")
. Q:C'=DF
. W !,IEN," ",$P(A,"^")," ok to change? " R OK:60 W " " I OK="^" S OUT=1 Q
. I OK'="Y" Q
. S $P(^PS(50.7,IEN,0),"^",6)=MRP
Q
EXIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS0114 781 printed Sep 23, 2025@20:04:43 Page 2
PSS0114 ;BIR/JLC-UPDATE ORDERABLE ITEMS WITH DEFAULT MED ROUTES ;08/28/2006
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**114**;9/30/97;Build 2
+2 ;
+3 ;
+4 NEW A,B,C,DF,Y,MRP,MR,OUT,IEN,OK,X
EN KILL DIC
SET DIC="^PS(50.606,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select DOSAGE FORM: "
DO ^DIC
KILL DIC
if X=""!(X="^")
QUIT
IF Y<0
GOTO EN
+1 SET DF=$PIECE(Y,"^",2)
EN1 KILL DIC
SET DIC="^PS(51.2,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select MEDICATION ROUTE: "
DO ^DIC
KILL DIC
if X=""!(X="^")
QUIT
IF Y<0
GOTO EN1
+1 WRITE !
SET MRP=$PIECE(Y,"^")
SET MR=$PIECE(Y,"^",2)
SET (OUT,IEN)=0
+2 FOR
SET IEN=$ORDER(^PS(50.7,IEN))
if 'IEN
QUIT
Begin DoDot:1
+3 SET A=$GET(^(IEN,0))
if $PIECE(A,"^",6)]""
QUIT
SET B=$PIECE(A,"^",2)
if B=""
QUIT
SET C=$PIECE($GET(^PS(50.606,B,0)),"^")
+4 if C'=DF
QUIT
+5 WRITE !,IEN," ",$PIECE(A,"^")," ok to change? "
READ OK:60
WRITE " "
IF OK="^"
SET OUT=1
QUIT
+6 IF OK'="Y"
QUIT
+7 SET $PIECE(^PS(50.7,IEN,0),"^",6)=MRP
End DoDot:1
if OUT
QUIT
+8 QUIT
EXIT QUIT
