- 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 Feb 18, 2025@23:59:01 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
