PSSMARK ;BIR/WRT-Review single NDF matches for CMOP ; 9/14/11 11:29am
;;1.0;PHARMACY DATA MANAGEMENT;**15,17,20,28,57,82,124,170,200**;9/30/97;Build 29
;
;Reference to ^PS(59 supported by DBIA #1976
;Reference to ^PS(50.605 supported by DBIA #2138
;Reference to ^PSNTRAN("END" supported by DBIA #2527
;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531
;Reference to $$CPTIER^PSNAPIS(P2,P2,P3) supported by DBIA #2531
;
PICK S U="^" S PSXFL=0 D TEXT F PSXMM=1:1 D PICK1 S:'$D(PSXFL) PSXFL=0 Q:PSXFL
DONE K PSXBT,PSXF,PSXFL,PSXVAP,PSXVP,PSXGN,PSXUM,PSXDN,PSXDP,PSXCMOP,PSXLOC,PSXZERO,PSXODE,PSXMM,PSXOU,PSXG,X,Y,PSXIDENT,PSXNDF,PSXVAPN,NONCE,PSXNEXT,PSXLAST,RTC,PSXNOW,PSXID,PSSEXP
Q
TEXT W !!,"This option allows you to choose entries from your drug file and helps you",!,"review your NDF matches and mark individual entries to send to CMOP.",!
W !,"If you mark the entry to transmit to CMOP, it will replace your Dispense Unit",!,"with the VA Dispense Unit. In addition, you may overwrite the local drug name",!,"with the VA Print Name and the entry will remain uneditable.",!
Q
DISPLAY W @IOF W !!?3,"Local Drug Generic Name: ",PSXLOC W !!,?16,"ORDER UNIT: "
I $D(^PSDRUG(PSXUM,660)) S PSXODE=^PSDRUG(PSXUM,660) I $P(PSXODE,"^",2) S PSXOU=$P(PSXODE,"^",2) I $D(^DIC(51.5)),$D(^DIC(51.5,PSXOU)) W ?28,$S('$D(PSXOU):"",1:$P(^DIC(51.5,PSXOU,0),"^",1))
W !,"DISPENSE UNITS/ORDER UNITS: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",5)),!,?13,"DISPENSE UNIT: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",8)),!," PRICE PER DISPENSE UNIT: ",$S('$D(PSXODE):"",1:$P(PSXODE,"^",6))
W !!,"VA Print Name: ",PSXVAP,?59,"VA Dispense Unit: ",PSXDP,!,"VA Drug Class: ",$P(^PS(50.605,$P(PSXDN,"^",6),0),"^",1),?50,"CMOP ID: ",PSXID
N CPDATE,X,PSNCP D NOW^%DTC S CPDATE=X S PSNCP=$$CPTIER^PSNAPIS("",CPDATE,PSXUM) K CPDATE,X W !,"COPAY Tier: ",$P(PSNCP,"^",1)
D CHECK
Q
CHECK I $D(^PSDRUG("AQ",PSXUM)),$P(^PSDRUG(PSXUM,3),"^",1)=1 D UNMARK
Q:PSXBT=1 I '$D(^PSDRUG("AQ",PSXUM)) D MARK
Q
MARK Q:PSXBT=1 W !!,"Do you wish to mark this drug to transmit to CMOP? " K DIR S DIR(0)="Y" D ^DIR D OUT I (Y=0)!($D(DUOUT)) K X,Y,DIRUT S PSXBT=1,PSXF=1 Q:PSXF=1 Q:PSXBT=1
I Y=1 S $P(^PSDRUG(PSXUM,660),"^",8)=PSXDP,^PSDRUG(PSXUM,3)=1,^PSDRUG("AQ",PSXUM)="",DA=PSXUM D ^PSSREF,IDENT K DA D QDM,QUEST,QUES2 S PSXF=1 ;;<RJS*170
Q
UNMARK Q:PSXF=1 W !!,"Do you wish to UNmark this drug to transmit to CMOP? " K DIR S DIR(0)="Y" D ^DIR D OUT I (Y=0)!($D(DUOUT)) K X,Y,DIRUT S PSXF=1 Q
I Y=1 S $P(^PSDRUG(PSXUM,3),"^",1)=0 K ^PSDRUG("AQ",PSXUM) S DA=PSXUM D ^PSSREF K DA S PSXF=1,PSXBT=1 Q:PSXBT=1 ;;<RJS*170
Q
QUES2 W !!,"Do you wish to overwrite your local name? " K DIR S DIR(0)="Y",DIR("?")="If you answer ""yes"", you will overwrite GENERIC NAME with the VA Print Name." D ^DIR D OUT I (Y=0)!($D(DUOUT)) D SYN K X,Y,DIRUT S PSXG=1 Q:PSXG=1
I Y=1 D DUP I '$D(^PSDRUG("B",PSXVAP)) S $P(^PSDRUG(PSXUM,0),"^",1)=PSXVAP D XREF,OLDNM S PSXF=1,PSXG=1 ;;<RJS*170
Q
DUP I PSXVAP'=PSXLOC,$D(^PSDRUG("B",PSXVAP)) W !,"You cannot write over the GENERIC NAME because one already has that",!,"VA Print Name. You cannot have duplicate names.",!
Q
XREF K:PSXLOC'=PSXVAP ^PSDRUG("B",PSXLOC,PSXUM) S:PSXLOC'=PSXVAP ^PSDRUG("B",PSXVAP,PSXUM)="" I $D(^PSNTRAN(PSXUM,"END")) S $P(^PSNTRAN(PSXUM,"END"),"^",3)=PSXVAP,$P(^PSNTRAN("END"),"^",3)=PSXVAP
Q
BLD ;
I $D(^PSDRUG(PSXUM,"I")) D ;; <*124 RJS
.N X,X1,X2
.S X1=$G(^PSDRUG(PSXUM,"I")),X2=DT D ^%DTC
.S:X<1 PSSEXP(1)="It has been inactivated." ;; *124 RJS >
I $D(^PSDRUG(PSXUM,2)),$P(^PSDRUG(PSXUM,2),"^",3)'["O" S PSSEXP(2)="It is not marked for outpatient pharmacy use."
BLD5 I $P(^PSDRUG(PSXUM,0),"^",3)[1!($P(^(0),"^",3)[2) S PSSEXP(3)="It is a schedule I or schedule II controlled substance."
I '$D(^PSDRUG(PSXUM,"ND")) S PSSEXP(4)="It is not matched to NDF."
I $D(^PSDRUG(PSXUM,"ND")),$P(^PSDRUG(PSXUM,"ND"),"^",2)']"" S PSSEXP(5)="It is not matched to NDF."
;
BLD1 S PSSXX="" I $D(^PSDRUG(PSXUM,"ND")) S PSXDN=^PSDRUG(PSXUM,"ND"),PSXGN=$P(PSXDN,"^",1),PSXVP=$P(PSXDN,"^",3) S PSSXX=$$PROD2^PSNAPIS(PSXGN,PSXVP)
I $P(PSSXX,"^",3)'=1 S PSSEXP(6)="It is not marked for CMOP in NDF." Q
I '$O(PSSEXP(0)),PSSXX]"",$P(PSSXX,"^",3)=1 S PSXVAP=$P(PSSXX,"^"),PSXDP=$P(PSSXX,"^",4)
Q
PICK1 S DIC="^PSDRUG(",DIC(0)="QEAM" D ^DIC K DIC I Y<0 S PSXFL=1 Q
K PSSEXP
S PSXUM=+Y,PSXLOC=$P(Y,"^",2) S PSSEXP(0)="",PSXF=0,PSXBT=0 D BLD
PICK2 I $O(PSSEXP(0)) W !!,"This drug cannot be marked for the following reason(s).",! F PSSXX=0:0 S PSSXX=$O(PSSEXP(PSSXX)) Q:'PSSXX W !,PSSEXP(PSSXX)
I $O(PSSEXP(0)) K PSSEXP W ! Q
GOTIT S PSXID=$P(PSSXX,"^",2),PSXZERO=^PSDRUG(PSXUM,0) D DISPLAY
N XX,DNSNAM,DNSPORT,DVER,DMFU S XX=""
I '$G(PSSHUIDG) D DRG^PSSHUIDG(PSXUM) D Q:PSXF Q:PSXBT
. F XX=0:0 S XX=$O(^PS(59,XX)) Q:'XX D
..S DVER=$$GET1^DIQ(59,XX_",",105,"I"),DMFU=$$GET1^DIQ(59,XX_",",105.2)
..I DVER="2.4" S DNSNAM=$$GET1^DIQ(59,XX_",",2006),DNSPORT=$$GET1^DIQ(59,XX_",",2007) D:$G(DNSNAM)&(DMFU="YES") DRG^PSSDGUPD(PSXUM,"",DNSNAM,DNSPORT)
Q
OUT I $D(DTOUT),DTOUT=1 S PSXFL=1
Q
IDENT S PSXNDF=$P(^PSDRUG(PSXUM,"ND"),"^",1),PSXVAPN=$P(^PSDRUG(PSXUM,"ND"),"^",3),DA=PSXNDF,K=PSXVAPN S X=$$PROD2^PSNAPIS(DA,K),PSXIDENT=$P(X,"^",2),$P(^PSDRUG(PSXUM,"ND"),"^",10)=PSXIDENT,^PSDRUG("AQ1",PSXIDENT,PSXUM)=""
Q
QUEST I $D(PSXODE),$P(PSXODE,"^",8)'=PSXDP W !!,"Your old Dispense Unit ",$P(PSXODE,"^",8)," does not match the new one ",PSXDP,".",!,"You may wish to edit the Price Per Order Unit and/or The Dispense",!,"Units Per Order Unit.",! D QUESTA
Q
QUESTA S DIE="^PSDRUG(",DA=PSXUM,DR="13;15",DIE("NO^")="BACK" D ^DIE K DIE("NO^")
Q
OLDNM D OLD I $D(NONCE) D OLD1
Q
OLD D NOW^%DTC I $D(^PSDRUG(PSXUM,900,1,0)) S NONCE=0,PSXLAST=0 F RTC=0:0 S RTC=$O(^PSDRUG(PSXUM,900,RTC)) Q:'RTC S PSXLAST=PSXLAST+1,PSXNEXT=PSXLAST+1
I '$D(^PSDRUG(PSXUM,900,1,0)) S ^PSDRUG(PSXUM,900,1,0)=PSXLOC_"^"_X
Q
OLD1 I NONCE=0 S ^PSDRUG(PSXUM,900,PSXNEXT,0)=PSXLOC_"^"_X,NONCE=1
Q
SYN S:'$D(^PSDRUG(PSXUM,1,0)) ^PSDRUG(PSXUM,1,0)="^50.1A^0^0" I '$D(^PSDRUG("C",PSXVAP,PSXUM)) S PSXNOW=$P(^PSDRUG(PSXUM,1,0),"^",3)+1,^PSDRUG(PSXUM,1,PSXNOW,0)=PSXVAP,^PSDRUG("C",PSXVAP,PSXUM,PSXNOW)="" D SYN1
Q
SYN1 S $P(^PSDRUG(PSXUM,1,0),"^",3)=PSXNOW,$P(^PSDRUG(PSXUM,1,0),"^",4)=$P(^PSDRUG(PSXUM,1,0),"^",4)+1
Q
QDM S DIE="^PSDRUG(",DA=PSXUM,DR=215 D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSMARK 6353 printed Apr 09, 2024@21:34:53 Page 2
PSSMARK ;BIR/WRT-Review single NDF matches for CMOP ; 9/14/11 11:29am
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**15,17,20,28,57,82,124,170,200**;9/30/97;Build 29
+2 ;
+3 ;Reference to ^PS(59 supported by DBIA #1976
+4 ;Reference to ^PS(50.605 supported by DBIA #2138
+5 ;Reference to ^PSNTRAN("END" supported by DBIA #2527
+6 ;Reference to $$PROD2^PSNAPIS(P1,P3) supported by DBIA #2531
+7 ;Reference to $$CPTIER^PSNAPIS(P2,P2,P3) supported by DBIA #2531
+8 ;
PICK SET U="^"
SET PSXFL=0
DO TEXT
FOR PSXMM=1:1
DO PICK1
if '$DATA(PSXFL)
SET PSXFL=0
if PSXFL
QUIT
DONE KILL PSXBT,PSXF,PSXFL,PSXVAP,PSXVP,PSXGN,PSXUM,PSXDN,PSXDP,PSXCMOP,PSXLOC,PSXZERO,PSXODE,PSXMM,PSXOU,PSXG,X,Y,PSXIDENT,PSXNDF,PSXVAPN,NONCE,PSXNEXT,PSXLAST,RTC,PSXNOW,PSXID,PSSEXP
+1 QUIT
TEXT WRITE !!,"This option allows you to choose entries from your drug file and helps you",!,"review your NDF matches and mark individual entries to send to CMOP.",!
+1 WRITE !,"If you mark the entry to transmit to CMOP, it will replace your Dispense Unit",!,"with the VA Dispense Unit. In addition, you may overwrite the local drug name",!,"with the VA Print Name and the entry will remain uneditable.",!
+2 QUIT
DISPLAY WRITE @IOF
WRITE !!?3,"Local Drug Generic Name: ",PSXLOC
WRITE !!,?16,"ORDER UNIT: "
+1 IF $DATA(^PSDRUG(PSXUM,660))
SET PSXODE=^PSDRUG(PSXUM,660)
IF $PIECE(PSXODE,"^",2)
SET PSXOU=$PIECE(PSXODE,"^",2)
IF $DATA(^DIC(51.5))
IF $DATA(^DIC(51.5,PSXOU))
WRITE ?28,$SELECT('$DATA(PSXOU):"",1:$PIECE(^DIC(51.5,PSXOU,0),"^",1))
+2 WRITE !,"DISPENSE UNITS/ORDER UNITS: ",$SELECT('$DATA(PSXODE):"",1:$PIECE(PSXODE,"^",5)),!,?13,"DISPENSE UNIT: ",$SELECT('$DATA(PSXODE):"",1:$PIECE(PSXODE,"^",8)),!," PRICE PER DISPENSE UNIT: ",$SELECT('$DATA(PSXODE):"",1:$PIECE(PSXODE,"^",6)
)
+3 WRITE !!,"VA Print Name: ",PSXVAP,?59,"VA Dispense Unit: ",PSXDP,!,"VA Drug Class: ",$PIECE(^PS(50.605,$PIECE(PSXDN,"^",6),0),"^",1),?50,"CMOP ID: ",PSXID
+4 NEW CPDATE,X,PSNCP
DO NOW^%DTC
SET CPDATE=X
SET PSNCP=$$CPTIER^PSNAPIS("",CPDATE,PSXUM)
KILL CPDATE,X
WRITE !,"COPAY Tier: ",$PIECE(PSNCP,"^",1)
+5 DO CHECK
+6 QUIT
CHECK IF $DATA(^PSDRUG("AQ",PSXUM))
IF $PIECE(^PSDRUG(PSXUM,3),"^",1)=1
DO UNMARK
+1 if PSXBT=1
QUIT
IF '$DATA(^PSDRUG("AQ",PSXUM))
DO MARK
+2 QUIT
MARK if PSXBT=1
QUIT
WRITE !!,"Do you wish to mark this drug to transmit to CMOP? "
KILL DIR
SET DIR(0)="Y"
DO ^DIR
DO OUT
IF (Y=0)!($DATA(DUOUT))
KILL X,Y,DIRUT
SET PSXBT=1
SET PSXF=1
if PSXF=1
QUIT
if PSXBT=1
QUIT
+1 ;;<RJS*170
IF Y=1
SET $PIECE(^PSDRUG(PSXUM,660),"^",8)=PSXDP
SET ^PSDRUG(PSXUM,3)=1
SET ^PSDRUG("AQ",PSXUM)=""
SET DA=PSXUM
DO ^PSSREF
DO IDENT
KILL DA
DO QDM
DO QUEST
DO QUES2
SET PSXF=1
+2 QUIT
UNMARK if PSXF=1
QUIT
WRITE !!,"Do you wish to UNmark this drug to transmit to CMOP? "
KILL DIR
SET DIR(0)="Y"
DO ^DIR
DO OUT
IF (Y=0)!($DATA(DUOUT))
KILL X,Y,DIRUT
SET PSXF=1
QUIT
+1 ;;<RJS*170
IF Y=1
SET $PIECE(^PSDRUG(PSXUM,3),"^",1)=0
KILL ^PSDRUG("AQ",PSXUM)
SET DA=PSXUM
DO ^PSSREF
KILL DA
SET PSXF=1
SET PSXBT=1
if PSXBT=1
QUIT
+2 QUIT
QUES2 WRITE !!,"Do you wish to overwrite your local name? "
KILL DIR
SET DIR(0)="Y"
SET DIR("?")="If you answer ""yes"", you will overwrite GENERIC NAME with the VA Print Name."
DO ^DIR
DO OUT
IF (Y=0)!($DATA(DUOUT))
DO SYN
KILL X,Y,DIRUT
SET PSXG=1
if PSXG=1
QUIT
+1 ;;<RJS*170
IF Y=1
DO DUP
IF '$DATA(^PSDRUG("B",PSXVAP))
SET $PIECE(^PSDRUG(PSXUM,0),"^",1)=PSXVAP
DO XREF
DO OLDNM
SET PSXF=1
SET PSXG=1
+2 QUIT
DUP IF PSXVAP'=PSXLOC
IF $DATA(^PSDRUG("B",PSXVAP))
WRITE !,"You cannot write over the GENERIC NAME because one already has that",!,"VA Print Name. You cannot have duplicate names.",!
+1 QUIT
XREF if PSXLOC'=PSXVAP
KILL ^PSDRUG("B",PSXLOC,PSXUM)
if PSXLOC'=PSXVAP
SET ^PSDRUG("B",PSXVAP,PSXUM)=""
IF $DATA(^PSNTRAN(PSXUM,"END"))
SET $PIECE(^PSNTRAN(PSXUM,"END"),"^",3)=PSXVAP
SET $PIECE(^PSNTRAN("END"),"^",3)=PSXVAP
+1 QUIT
BLD ;
+1 ;; <*124 RJS
IF $DATA(^PSDRUG(PSXUM,"I"))
Begin DoDot:1
+2 NEW X,X1,X2
+3 SET X1=$GET(^PSDRUG(PSXUM,"I"))
SET X2=DT
DO ^%DTC
+4 ;; *124 RJS >
if X<1
SET PSSEXP(1)="It has been inactivated."
End DoDot:1
+5 IF $DATA(^PSDRUG(PSXUM,2))
IF $PIECE(^PSDRUG(PSXUM,2),"^",3)'["O"
SET PSSEXP(2)="It is not marked for outpatient pharmacy use."
BLD5 IF $PIECE(^PSDRUG(PSXUM,0),"^",3)[1!($PIECE(^(0),"^",3)[2)
SET PSSEXP(3)="It is a schedule I or schedule II controlled substance."
+1 IF '$DATA(^PSDRUG(PSXUM,"ND"))
SET PSSEXP(4)="It is not matched to NDF."
+2 IF $DATA(^PSDRUG(PSXUM,"ND"))
IF $PIECE(^PSDRUG(PSXUM,"ND"),"^",2)']""
SET PSSEXP(5)="It is not matched to NDF."
+3 ;
BLD1 SET PSSXX=""
IF $DATA(^PSDRUG(PSXUM,"ND"))
SET PSXDN=^PSDRUG(PSXUM,"ND")
SET PSXGN=$PIECE(PSXDN,"^",1)
SET PSXVP=$PIECE(PSXDN,"^",3)
SET PSSXX=$$PROD2^PSNAPIS(PSXGN,PSXVP)
+1 IF $PIECE(PSSXX,"^",3)'=1
SET PSSEXP(6)="It is not marked for CMOP in NDF."
QUIT
+2 IF '$ORDER(PSSEXP(0))
IF PSSXX]""
IF $PIECE(PSSXX,"^",3)=1
SET PSXVAP=$PIECE(PSSXX,"^")
SET PSXDP=$PIECE(PSSXX,"^",4)
+3 QUIT
PICK1 SET DIC="^PSDRUG("
SET DIC(0)="QEAM"
DO ^DIC
KILL DIC
IF Y<0
SET PSXFL=1
QUIT
+1 KILL PSSEXP
+2 SET PSXUM=+Y
SET PSXLOC=$PIECE(Y,"^",2)
SET PSSEXP(0)=""
SET PSXF=0
SET PSXBT=0
DO BLD
PICK2 IF $ORDER(PSSEXP(0))
WRITE !!,"This drug cannot be marked for the following reason(s).",!
FOR PSSXX=0:0
SET PSSXX=$ORDER(PSSEXP(PSSXX))
if 'PSSXX
QUIT
WRITE !,PSSEXP(PSSXX)
+1 IF $ORDER(PSSEXP(0))
KILL PSSEXP
WRITE !
QUIT
GOTIT SET PSXID=$PIECE(PSSXX,"^",2)
SET PSXZERO=^PSDRUG(PSXUM,0)
DO DISPLAY
+1 NEW XX,DNSNAM,DNSPORT,DVER,DMFU
SET XX=""
+2 IF '$GET(PSSHUIDG)
DO DRG^PSSHUIDG(PSXUM)
Begin DoDot:1
+3 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
if 'XX
QUIT
Begin DoDot:2
+4 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+5 IF DVER="2.4"
SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
if $GET(DNSNAM)&(DMFU="YES")
DO DRG^PSSDGUPD(PSXUM,"",DNSNAM,DNSPORT)
End DoDot:2
End DoDot:1
if PSXF
QUIT
if PSXBT
QUIT
+6 QUIT
OUT IF $DATA(DTOUT)
IF DTOUT=1
SET PSXFL=1
+1 QUIT
IDENT SET PSXNDF=$PIECE(^PSDRUG(PSXUM,"ND"),"^",1)
SET PSXVAPN=$PIECE(^PSDRUG(PSXUM,"ND"),"^",3)
SET DA=PSXNDF
SET K=PSXVAPN
SET X=$$PROD2^PSNAPIS(DA,K)
SET PSXIDENT=$PIECE(X,"^",2)
SET $PIECE(^PSDRUG(PSXUM,"ND"),"^",10)=PSXIDENT
SET ^PSDRUG("AQ1",PSXIDENT,PSXUM)=""
+1 QUIT
QUEST IF $DATA(PSXODE)
IF $PIECE(PSXODE,"^",8)'=PSXDP
WRITE !!,"Your old Dispense Unit ",$PIECE(PSXODE,"^",8)," does not match the new one ",PSXDP,".",!,"You may wish to edit the Price Per Order Unit and/or The Dispense",!,"Units Per Order Unit.",!
DO QUESTA
+1 QUIT
QUESTA SET DIE="^PSDRUG("
SET DA=PSXUM
SET DR="13;15"
SET DIE("NO^")="BACK"
DO ^DIE
KILL DIE("NO^")
+1 QUIT
OLDNM DO OLD
IF $DATA(NONCE)
DO OLD1
+1 QUIT
OLD DO NOW^%DTC
IF $DATA(^PSDRUG(PSXUM,900,1,0))
SET NONCE=0
SET PSXLAST=0
FOR RTC=0:0
SET RTC=$ORDER(^PSDRUG(PSXUM,900,RTC))
if 'RTC
QUIT
SET PSXLAST=PSXLAST+1
SET PSXNEXT=PSXLAST+1
+1 IF '$DATA(^PSDRUG(PSXUM,900,1,0))
SET ^PSDRUG(PSXUM,900,1,0)=PSXLOC_"^"_X
+2 QUIT
OLD1 IF NONCE=0
SET ^PSDRUG(PSXUM,900,PSXNEXT,0)=PSXLOC_"^"_X
SET NONCE=1
+1 QUIT
SYN if '$DATA(^PSDRUG(PSXUM,1,0))
SET ^PSDRUG(PSXUM,1,0)="^50.1A^0^0"
IF '$DATA(^PSDRUG("C",PSXVAP,PSXUM))
SET PSXNOW=$PIECE(^PSDRUG(PSXUM,1,0),"^",3)+1
SET ^PSDRUG(PSXUM,1,PSXNOW,0)=PSXVAP
SET ^PSDRUG("C",PSXVAP,PSXUM,PSXNOW)=""
DO SYN1
+1 QUIT
SYN1 SET $PIECE(^PSDRUG(PSXUM,1,0),"^",3)=PSXNOW
SET $PIECE(^PSDRUG(PSXUM,1,0),"^",4)=$PIECE(^PSDRUG(PSXUM,1,0),"^",4)+1
+1 QUIT
QDM SET DIE="^PSDRUG("
SET DA=PSXUM
SET DR=215
DO ^DIE
+1 QUIT
