PSSPOIDT ;BIR/RTR/WRT-Date update in Orderable Item File ;02/14/00
;;1.0;PHARMACY DATA MANAGEMENT;**19,29,38,57,68,69,82**;9/30/97
;Reference to ^PS(59 supported by DBIA #1976
;Passed in is Internal number of Pharmacy Orderable Item
;Changed all IIII's to II (PWC-4/5/04). Lines were too long to add new code.
EN(PSPOINT) ;
EN1 I $G(PSSCROSS) S:$G(PSSTEST) PSPOINT=PSSTEST I '$G(PSSTEST)!('$D(^PS(50.7,+$G(PSSTEST),0))) S:$D(ZTQUEUED) ZTREQ="@" Q
N DA,DR,DIE,X,Y,ZZZ,ZZZA,ZZZS,PSUAPP,INACFLAG,PSSVAP,PSSVNAME,PSSVDOSE,INCDATE,PSACDATE,WWWW,PSLATEST,PSSORDIT
Q:'$D(^PS(50.7,PSPOINT,0))
I $P(^PS(50.7,PSPOINT,0),"^",4) D SET G ENT
S PSSVNAME=$P($G(^PS(50.7,PSPOINT,0)),"^"),PSSVDOSE=$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")
S PSACDATE=DT,PSLATEST=0
S INACFLAG=0
F ZZZ=0:0 S ZZZ=$O(^PS(50.7,"A50",PSPOINT,ZZZ)) Q:'ZZZ D
.S PSUAPP=$P($G(^PSDRUG(ZZZ,2)),"^",3) I PSUAPP["O"!(PSUAPP["X")!(PSUAPP["I")!(PSUAPP["U") S PSSVAP=$P($G(^PSDRUG(ZZZ,"I")),"^") S:PSSVAP&(PSSVAP>PSLATEST) PSLATEST=PSSVAP I 'PSSVAP S INACFLAG=1
.F ZZZA=0:0 S ZZZA=$O(^PSDRUG("A526",ZZZ,ZZZA)) Q:'ZZZA I $D(^PS(52.6,ZZZA,0)) S PSSVAP=+$P($G(^PS(52.6,ZZZA,"I")),"^") D
..S:PSSVAP&(PSSVAP>PSLATEST) PSLATEST=PSSVAP I 'PSSVAP S INACFLAG=1
.F ZZZS=0:0 S ZZZS=$O(^PSDRUG("A527",ZZZ,ZZZS)) Q:'ZZZS I $D(^PS(52.7,ZZZS,0)) S PSSVAP=+$P($G(^PS(52.7,ZZZS,"I")),"^") D
..S:PSSVAP&(PSSVAP>PSLATEST) PSLATEST=PSSVAP I 'PSSVAP S INACFLAG=1
I 'INACFLAG,'$P($G(^PS(50.7,PSPOINT,0)),"^",4) D
.W:'$G(PSSCROSS)&($G(PSLATEST)'>DT) !!,PSSVNAME," ",PSSVDOSE,!,"is being marked inactive since no Additives, Solutions, or Dispense Drugs",!,"marked with an 'I', 'O' or 'U' in the Application Package Use field are matched",!,"to it.",!
I 'INACFLAG,'$P($G(^PS(50.7,PSPOINT,0)),"^",4) S PSLATEST=$S('PSLATEST:DT,1:PSLATEST) S $P(^PS(50.7,PSPOINT,0),"^",4)=PSLATEST
D SET G ENT
Q
SUP(PSSORDIT) ;Supply at Orderable Item
ENT ;Enter here if coming from Inactive date, or from queued job
I '$D(^PS(50.7,PSSORDIT,0)) S:$D(ZTQUEUED) ZTREQ="@" Q
I $P(^PS(50.7,PSSORDIT,0),"^",3) D NONFORM G ENTZ
N ZZZ,ZZZZ,PSSSUP,PSSSUYES,PSSSAP,PSSINA,PSSQDATE,PSSQYES,HLDCROSS
D NONFORM,NONVA
S PSSSUP=$P(^PS(50.7,PSSORDIT,0),"^",9),(PSSSUYES,PSSQYES)=0 F ZZZ=0:0 S ZZZ=$O(^PS(50.7,"A50",PSSORDIT,ZZZ)) Q:'ZZZ!(PSSQYES) D
.I $P($G(^PSDRUG(ZZZ,0)),"^",3)["S" S PSSSAP=$P($G(^(2)),"^",3),PSSINA=$P($G(^("I")),"^") D
..I PSSSAP["O"!(PSSSAP["I")!(PSSSAP["U")!(PSSSAP["X") I 'PSSINA S (PSSQYES,PSSSUYES)=1 Q
..I PSSSAP["O"!(PSSSAP["I")!(PSSSAP["U")!(PSSSAP["X") I +PSSINA>DT S PSSQDATE($E(PSSINA,1,7))="",PSSSUYES=1
I 'PSSSUP,PSSSUYES S $P(^PS(50.7,PSSORDIT,0),"^",9)=1 W:'$G(PSSCROSS) !!,"The supply indicator is now being set for the Orderable Item",!,$P(^PS(50.7,PSSORDIT,0),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),!
I PSSSUP,'PSSSUYES S $P(^PS(50.7,PSSORDIT,0),"^",9)="" W:'$G(PSSCROSS) !!,"The supply indicator is now being removed for the Orderable Item",!,$P(^PS(50.7,PSSORDIT,0),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),!
I 'PSSQYES,PSSSUYES,$O(PSSQDATE(0)) F ZZZZ=0:0 S ZZZZ=$O(PSSQDATE(ZZZZ)) Q:'ZZZZ D
.S ZTRTN="ENT^PSSPOIDT",ZTIO="",ZTDTH=ZZZZ_.01,ZTDESC="Supply update for Orderable Item",ZTSAVE("PSSORDIT")="" S HLDCROSS=$G(PSSCROSS) S PSSCROSS=1,ZTSAVE("PSSCROSS")="" D ^%ZTLOAD K:'$G(HLDCROSS) PSSCROSS
ENTZ I $G(PSSCROSS) D EN2^PSSHL1(PSSORDIT,"MUP")
S:$D(ZTQUEUED) ZTREQ="@"
Q
SET S PSSORDIT=PSPOINT
Q
REST(PSSREST) ;Ask to reactivate or inactivate others
ASKQ K DIR W ! S DIR("A",1)="Do you want to "_$S(PSINORDE="I":"inactivate",1:"reactivate")_" all Drugs/Additives/Solutions",DIR("A")="that are matched to this Orderable Item?"
S DIR(0)="SB^Y:YES;N:NO;L:LIST ALL DRUGS/ADDITIVES/SOLUTIONS",DIR("B")="N" D ^DIR K DIR Q:$D(DIRUT)!($D(DUOUT))!($D(DTOUT))
;I Y="L" H 1 D @$S($P(^PS(50.7,PSSREST,0),"^",3):"LADD",1:"LDIS") W:FLAG&($P(^PS(50.7,PSSREST,0),"^",3)) !!,"Nothing matched to this Orderable Item!",! G:FLAG QREST G ASKQ
I Y="L" K PSSCXXX,PSSCOUT D LDIS W:'$G(PSSCXXX)&('$G(PSSCOUT)) !!,"Nothing matched to this Orderable Item.",! G:'$G(PSSCXXX)&('$G(PSSCOUT)) QREST K PSSCXXX,PSSCOUT G ASKQ
I Y="Y" W !,"Please wait..",! D W !,"Finished!",!
.I $G(PSINORDE)="I" S PSIDATEX=$P($G(^PS(50.7,PSSREST,0)),"^",4) I PSIDATEX D
..F II=0:0 S II=$O(^PS(52.7,"AOI",PSSREST,II)) Q:'II I $D(^PS(52.7,II,0)) S $P(^PS(52.7,II,"I"),"^")=PSIDATEX
..F II=0:0 S II=$O(^PS(52.6,"AOI",PSSREST,II)) Q:'II I $D(^PS(52.6,II,0)) S $P(^PS(52.6,II,"I"),"^")=PSIDATEX
.I $G(PSINORDE)="D" D
..F II=0:0 S II=$O(^PS(52.7,"AOI",PSSREST,II)) Q:'II I $D(^PS(52.7,II,0)),$P($G(^("I")),"^") S $P(^PS(52.7,II,"I"),"^")=""
..F II=0:0 S II=$O(^PS(52.6,"AOI",PSSREST,II)) Q:'II I $D(^PS(52.6,II,0)),$P($G(^("I")),"^") S $P(^PS(52.6,II,"I"),"^")=""
.I $G(PSINORDE)="I" S PSIDATEX=$P($G(^PS(50.7,PSSREST,0)),"^",4) I PSIDATEX F II=0:0 S II=$O(^PSDRUG("ASP",PSSREST,II)) Q:'II I $D(^PSDRUG(II,0)) S $P(^PSDRUG(II,"I"),"^")=PSIDATEX D:'$G(PSSHUIDG) DRG^PSSHUIDG(II) D
..N XX,DVER,DNSNAM,DNSPORT,DMFU S XX=""
..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) I DNSNAM'=""&(DMFU="YES") D DRG^PSSDGUPD(II,"",DNSNAM,DNSPORT)
.I $G(PSINORDE)="D" F II=0:0 S II=$O(^PSDRUG("ASP",PSSREST,II)) Q:'II I $D(^PSDRUG(II,0)),$P($G(^PSDRUG(II,"I")),"^") S DA=II,DIE=50,DR="100///@" D ^DIE D:'$G(PSSHUIDG) DRG^PSSHUIDG(DA) D
..N XX,DVER,DNSNAM,DNSPORT,DMFU S XX=""
..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) I DNSNAM'=""&(DMFU="YES") D DRG^PSSDGUPD(II,"",DNSNAM,DNSPORT)
. K DA,DIE,DR
K II,PSIDATEX
QREST K PSSCXXX,PSSCOUT Q
LDIS ;list dispense drugs
N FLAG,PSSCFLAG,PSSCDATE,ZZ
S FLAG=1,(PSSCOUT,PSSCXXX)=0 D DHEAD F ZZ=0:0 S ZZ=$O(^PSDRUG("ASP",PSSREST,ZZ)) Q:'ZZ!($G(PSSCOUT)) S FLAG=0 D:($Y+5)>IOSL DHEAD Q:$G(PSSCOUT) I ZZ S PSSCXXX=1 W !,$P($G(^PSDRUG(ZZ,0)),"^") D DTE
Q:$G(PSSCOUT)
S (FLAG,PSSCFLAG)=0
F ZZ=0:0 S ZZ=$O(^PS(52.6,"AOI",PSSREST,ZZ)) Q:'ZZ!($G(PSSCOUT)) D:($Y+5)>IOSL DHEAD Q:$G(PSSCOUT) I ZZ D
.S (PSSCFLAG,PSSCXXX)=1
.W !,$P($G(^PS(52.6,ZZ,0)),"^"),?42,"(A)"
.S PSSCDATE=$P($G(^PS(52.6,ZZ,"I")),"^") I PSSCDATE D DTEX
Q:$G(PSSCOUT)
;I $G(PSSCFLAG) W !
F ZZ=0:0 S ZZ=$O(^PS(52.7,"AOI",PSSREST,ZZ)) Q:'ZZ!($G(PSSCOUT)) D:($Y+5)>IOSL DHEAD Q:$G(PSSCOUT) I ZZ D
.W !,$P($G(^PS(52.7,ZZ,0)),"^"),?31,$P($G(^(0)),"^",3),?42,"(S)"
.S PSSCDATE=$P($G(^PS(52.7,ZZ,"I")),"^") I PSSCDATE D DTEX
Q
DHEAD I 'FLAG W ! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR I 'Y S PSSCOUT=1 Q
W @IOF W !,?6,"Orderable Item -> ",$P($G(^PS(50.7,PSSREST,0)),"^"),!?6,"Dosage Form -> ",$P($G(^PS(50.606,+$P($G(^PS(50.7,PSSREST,0)),"^",2),0)),"^"),!!,"Dispense Drugs:"_$S('FLAG:" (continued)",1:""),!,"---------------"
Q
DTE I $D(^PSDRUG(ZZ,"I")) S Y=$P(^PSDRUG(ZZ,"I"),"^") D DD^%DT W ?50,Y K Y
Q
DTEX S Y=$G(PSSCDATE) D DD^%DT W ?50,$G(Y) K Y
Q
NONFORM ;
;formulary status of Orderable Item
Q:'$G(PSSORDIT)
N PSNFX,PSNFX1,PSNFX2,PSNFXB
S (PSNFX1,PSNFX2)=0
S PSNFXB=$P($G(^PS(50.7,PSSORDIT,0)),"^",12)
F PSNFX=0:0 S PSNFX=$O(^PS(50.7,"A50",PSSORDIT,PSNFX)) Q:'PSNFX D
.I $P($G(^PSDRUG(PSNFX,2)),"^",3)'["O",$P($G(^(2)),"^",3)'["I",$P($G(^(2)),"^",3)'["U",$P($G(^(2)),"^",3)'["X" Q
.I $P($G(^PSDRUG(PSNFX,"I")),"^"),$P($G(^("I")),"^")'>DT Q
.I $P($G(^PSDRUG(PSNFX,0)),"^",9)=1 S PSNFX1=1 Q
.S PSNFX2=1
I PSNFX1,'PSNFX2 S $P(^PS(50.7,PSSORDIT,0),"^",12)=1
I PSNFX2 S $P(^PS(50.7,PSSORDIT,0),"^",12)=""
I $P($G(^PS(50.7,PSSORDIT,0)),"^",12)'=$G(PSNFXB),'$G(PSSCROSS) D
.W !!,"The Formulary Status of the Pharmacy Orderable Item",!,$P($G(^PS(50.7,PSSORDIT,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^"),!,"has been changed to "_$S($P($G(^PS(50.7,PSSORDIT,0)),"^",12):"Non-Formulary.",1:"Formulary."),!
Q
MSSG I '$G(PSSCROSS) W !!,"This Orderable Item is "_$S($P($G(^PS(50.7,PSSORDIT,0)),"^",12):"Non-Formulary.",1:"Formulary."),!
Q
NONVA ; Evaluates the Non-VA Med Indicator of the Orderable Item
N PSNVADG,PSNONVA,PSDRG
;
Q:'$G(PSSORDIT)
S PSNVADG=0,PSNONVA=$P($G(^PS(50.7,PSSORDIT,0)),"^",10),PSDRG=0
F S PSDRG=$O(^PS(50.7,"A50",PSSORDIT,PSDRG)) Q:'PSDRG!(PSNVADG) D
. I $P($G(^PSDRUG(PSDRG,"I")),"^"),$P($G(^("I")),"^")'>DT Q
. I $P($G(^PSDRUG(PSDRG,2)),"^",3)["X" S PSNVADG=1
;
I PSNVADG S $P(^PS(50.7,PSSORDIT,0),"^",10)=1
I 'PSNVADG S $P(^PS(50.7,PSSORDIT,0),"^",10)=""
;
I +$P($G(^PS(50.7,PSSORDIT,0)),"^",10)'=+PSNONVA,'$G(PSSCROSS) D
. W !!,"The Pharmacy Orderable Item ",$P($G(^PS(50.7,PSSORDIT,0)),"^")
. W !,"is ",$S('PSNONVA:"now",1:"no longer")," marked as a NON-VA MED Drug."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPOIDT 8895 printed Oct 16, 2024@18:34:40 Page 2
PSSPOIDT ;BIR/RTR/WRT-Date update in Orderable Item File ;02/14/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**19,29,38,57,68,69,82**;9/30/97
+2 ;Reference to ^PS(59 supported by DBIA #1976
+3 ;Passed in is Internal number of Pharmacy Orderable Item
+4 ;Changed all IIII's to II (PWC-4/5/04). Lines were too long to add new code.
EN(PSPOINT) ;
EN1 IF $GET(PSSCROSS)
if $GET(PSSTEST)
SET PSPOINT=PSSTEST
IF '$GET(PSSTEST)!('$DATA(^PS(50.7,+$GET(PSSTEST),0)))
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+1 NEW DA,DR,DIE,X,Y,ZZZ,ZZZA,ZZZS,PSUAPP,INACFLAG,PSSVAP,PSSVNAME,PSSVDOSE,INCDATE,PSACDATE,WWWW,PSLATEST,PSSORDIT
+2 if '$DATA(^PS(50.7,PSPOINT,0))
QUIT
+3 IF $PIECE(^PS(50.7,PSPOINT,0),"^",4)
DO SET
GOTO ENT
+4 SET PSSVNAME=$PIECE($GET(^PS(50.7,PSPOINT,0)),"^")
SET PSSVDOSE=$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")
+5 SET PSACDATE=DT
SET PSLATEST=0
+6 SET INACFLAG=0
+7 FOR ZZZ=0:0
SET ZZZ=$ORDER(^PS(50.7,"A50",PSPOINT,ZZZ))
if 'ZZZ
QUIT
Begin DoDot:1
+8 SET PSUAPP=$PIECE($GET(^PSDRUG(ZZZ,2)),"^",3)
IF PSUAPP["O"!(PSUAPP["X")!(PSUAPP["I")!(PSUAPP["U")
SET PSSVAP=$PIECE($GET(^PSDRUG(ZZZ,"I")),"^")
if PSSVAP&(PSSVAP>PSLATEST)
SET PSLATEST=PSSVAP
IF 'PSSVAP
SET INACFLAG=1
+9 FOR ZZZA=0:0
SET ZZZA=$ORDER(^PSDRUG("A526",ZZZ,ZZZA))
if 'ZZZA
QUIT
IF $DATA(^PS(52.6,ZZZA,0))
SET PSSVAP=+$PIECE($GET(^PS(52.6,ZZZA,"I")),"^")
Begin DoDot:2
+10 if PSSVAP&(PSSVAP>PSLATEST)
SET PSLATEST=PSSVAP
IF 'PSSVAP
SET INACFLAG=1
End DoDot:2
+11 FOR ZZZS=0:0
SET ZZZS=$ORDER(^PSDRUG("A527",ZZZ,ZZZS))
if 'ZZZS
QUIT
IF $DATA(^PS(52.7,ZZZS,0))
SET PSSVAP=+$PIECE($GET(^PS(52.7,ZZZS,"I")),"^")
Begin DoDot:2
+12 if PSSVAP&(PSSVAP>PSLATEST)
SET PSLATEST=PSSVAP
IF 'PSSVAP
SET INACFLAG=1
End DoDot:2
End DoDot:1
+13 IF 'INACFLAG
IF '$PIECE($GET(^PS(50.7,PSPOINT,0)),"^",4)
Begin DoDot:1
+14 if '$GET(PSSCROSS)&($GET(PSLATEST)'>DT)
WRITE !!,PSSVNAME," ",PSSVDOSE,!,"is being marked inactive since no Additives, Solutions, or Dispense Drugs",!,"marked with an 'I', 'O' or 'U' in the Application Package Use field are matched",!,"to it.",!
End DoDot:1
+15 IF 'INACFLAG
IF '$PIECE($GET(^PS(50.7,PSPOINT,0)),"^",4)
SET PSLATEST=$SELECT('PSLATEST:DT,1:PSLATEST)
SET $PIECE(^PS(50.7,PSPOINT,0),"^",4)=PSLATEST
+16 DO SET
GOTO ENT
+17 QUIT
SUP(PSSORDIT) ;Supply at Orderable Item
ENT ;Enter here if coming from Inactive date, or from queued job
+1 IF '$DATA(^PS(50.7,PSSORDIT,0))
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 IF $PIECE(^PS(50.7,PSSORDIT,0),"^",3)
DO NONFORM
GOTO ENTZ
+3 NEW ZZZ,ZZZZ,PSSSUP,PSSSUYES,PSSSAP,PSSINA,PSSQDATE,PSSQYES,HLDCROSS
+4 DO NONFORM
DO NONVA
+5 SET PSSSUP=$PIECE(^PS(50.7,PSSORDIT,0),"^",9)
SET (PSSSUYES,PSSQYES)=0
FOR ZZZ=0:0
SET ZZZ=$ORDER(^PS(50.7,"A50",PSSORDIT,ZZZ))
if 'ZZZ!(PSSQYES)
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^PSDRUG(ZZZ,0)),"^",3)["S"
SET PSSSAP=$PIECE($GET(^(2)),"^",3)
SET PSSINA=$PIECE($GET(^("I")),"^")
Begin DoDot:2
+7 IF PSSSAP["O"!(PSSSAP["I")!(PSSSAP["U")!(PSSSAP["X")
IF 'PSSINA
SET (PSSQYES,PSSSUYES)=1
QUIT
+8 IF PSSSAP["O"!(PSSSAP["I")!(PSSSAP["U")!(PSSSAP["X")
IF +PSSINA>DT
SET PSSQDATE($EXTRACT(PSSINA,1,7))=""
SET PSSSUYES=1
End DoDot:2
End DoDot:1
+9 IF 'PSSSUP
IF PSSSUYES
SET $PIECE(^PS(50.7,PSSORDIT,0),"^",9)=1
if '$GET(PSSCROSS)
WRITE !!,"The supply indicator is now being set for the Orderable Item",!,$PIECE(^PS(50.7,PSSORDIT,0),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^"),!
+10 IF PSSSUP
IF 'PSSSUYES
SET $PIECE(^PS(50.7,PSSORDIT,0),"^",9)=""
if '$GET(PSSCROSS)
WRITE !!,"The supply indicator is now being removed for the Orderable Item",!,$PIECE(^PS(50.7,PSSORDIT,0),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^"),!
+11 IF 'PSSQYES
IF PSSSUYES
IF $ORDER(PSSQDATE(0))
FOR ZZZZ=0:0
SET ZZZZ=$ORDER(PSSQDATE(ZZZZ))
if 'ZZZZ
QUIT
Begin DoDot:1
+12 SET ZTRTN="ENT^PSSPOIDT"
SET ZTIO=""
SET ZTDTH=ZZZZ_.01
SET ZTDESC="Supply update for Orderable Item"
SET ZTSAVE("PSSORDIT")=""
SET HLDCROSS=$GET(PSSCROSS)
SET PSSCROSS=1
SET ZTSAVE("PSSCROSS")=""
DO ^%ZTLOAD
if '$GET(HLDCROSS)
KILL PSSCROSS
End DoDot:1
ENTZ IF $GET(PSSCROSS)
DO EN2^PSSHL1(PSSORDIT,"MUP")
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
SET SET PSSORDIT=PSPOINT
+1 QUIT
REST(PSSREST) ;Ask to reactivate or inactivate others
ASKQ KILL DIR
WRITE !
SET DIR("A",1)="Do you want to "_$SELECT(PSINORDE="I":"inactivate",1:"reactivate")_" all Drugs/Additives/Solutions"
SET DIR("A")="that are matched to this Orderable Item?"
+1 SET DIR(0)="SB^Y:YES;N:NO;L:LIST ALL DRUGS/ADDITIVES/SOLUTIONS"
SET DIR("B")="N"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!($DATA(DUOUT))!($DATA(DTOUT))
QUIT
+2 ;I Y="L" H 1 D @$S($P(^PS(50.7,PSSREST,0),"^",3):"LADD",1:"LDIS") W:FLAG&($P(^PS(50.7,PSSREST,0),"^",3)) !!,"Nothing matched to this Orderable Item!",! G:FLAG QREST G ASKQ
+3 IF Y="L"
KILL PSSCXXX,PSSCOUT
DO LDIS
if '$GET(PSSCXXX)&('$GET(PSSCOUT))
WRITE !!,"Nothing matched to this Orderable Item.",!
if '$GET(PSSCXXX)&('$GET(PSSCOUT))
GOTO QREST
KILL PSSCXXX,PSSCOUT
GOTO ASKQ
+4 IF Y="Y"
WRITE !,"Please wait..",!
Begin DoDot:1
+5 IF $GET(PSINORDE)="I"
SET PSIDATEX=$PIECE($GET(^PS(50.7,PSSREST,0)),"^",4)
IF PSIDATEX
Begin DoDot:2
+6 FOR II=0:0
SET II=$ORDER(^PS(52.7,"AOI",PSSREST,II))
if 'II
QUIT
IF $DATA(^PS(52.7,II,0))
SET $PIECE(^PS(52.7,II,"I"),"^")=PSIDATEX
+7 FOR II=0:0
SET II=$ORDER(^PS(52.6,"AOI",PSSREST,II))
if 'II
QUIT
IF $DATA(^PS(52.6,II,0))
SET $PIECE(^PS(52.6,II,"I"),"^")=PSIDATEX
End DoDot:2
+8 IF $GET(PSINORDE)="D"
Begin DoDot:2
+9 FOR II=0:0
SET II=$ORDER(^PS(52.7,"AOI",PSSREST,II))
if 'II
QUIT
IF $DATA(^PS(52.7,II,0))
IF $PIECE($GET(^("I")),"^")
SET $PIECE(^PS(52.7,II,"I"),"^")=""
+10 FOR II=0:0
SET II=$ORDER(^PS(52.6,"AOI",PSSREST,II))
if 'II
QUIT
IF $DATA(^PS(52.6,II,0))
IF $PIECE($GET(^("I")),"^")
SET $PIECE(^PS(52.6,II,"I"),"^")=""
End DoDot:2
+11 IF $GET(PSINORDE)="I"
SET PSIDATEX=$PIECE($GET(^PS(50.7,PSSREST,0)),"^",4)
IF PSIDATEX
FOR II=0:0
SET II=$ORDER(^PSDRUG("ASP",PSSREST,II))
if 'II
QUIT
IF $DATA(^PSDRUG(II,0))
SET $PIECE(^PSDRUG(II,"I"),"^")=PSIDATEX
if '$GET(PSSHUIDG)
DO DRG^PSSHUIDG(II)
Begin DoDot:2
+12 NEW XX,DVER,DNSNAM,DNSPORT,DMFU
SET XX=""
+13 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
if 'XX
QUIT
Begin DoDot:3
End DoDot:3
+14 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+15 IF DVER="2.4"
SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
IF DNSNAM'=""&(DMFU="YES")
DO DRG^PSSDGUPD(II,"",DNSNAM,DNSPORT)
End DoDot:2
+16 IF $GET(PSINORDE)="D"
FOR II=0:0
SET II=$ORDER(^PSDRUG("ASP",PSSREST,II))
if 'II
QUIT
IF $DATA(^PSDRUG(II,0))
IF $PIECE($GET(^PSDRUG(II,"I")),"^")
SET DA=II
SET DIE=50
SET DR="100///@"
DO ^DIE
if '$GET(PSSHUIDG)
DO DRG^PSSHUIDG(DA)
Begin DoDot:2
+17 NEW XX,DVER,DNSNAM,DNSPORT,DMFU
SET XX=""
+18 FOR XX=0:0
SET XX=$ORDER(^PS(59,XX))
if 'XX
QUIT
Begin DoDot:3
End DoDot:3
+19 SET DVER=$$GET1^DIQ(59,XX_",",105,"I")
SET DMFU=$$GET1^DIQ(59,XX_",",105.2)
+20 IF DVER="2.4"
SET DNSNAM=$$GET1^DIQ(59,XX_",",2006)
SET DNSPORT=$$GET1^DIQ(59,XX_",",2007)
IF DNSNAM'=""&(DMFU="YES")
DO DRG^PSSDGUPD(II,"",DNSNAM,DNSPORT)
End DoDot:2
+21 KILL DA,DIE,DR
End DoDot:1
WRITE !,"Finished!",!
+22 KILL II,PSIDATEX
QREST KILL PSSCXXX,PSSCOUT
QUIT
LDIS ;list dispense drugs
+1 NEW FLAG,PSSCFLAG,PSSCDATE,ZZ
+2 SET FLAG=1
SET (PSSCOUT,PSSCXXX)=0
DO DHEAD
FOR ZZ=0:0
SET ZZ=$ORDER(^PSDRUG("ASP",PSSREST,ZZ))
if 'ZZ!($GET(PSSCOUT))
QUIT
SET FLAG=0
if ($Y+5)>IOSL
DO DHEAD
if $GET(PSSCOUT)
QUIT
IF ZZ
SET PSSCXXX=1
WRITE !,$PIECE($GET(^PSDRUG(ZZ,0)),"^")
DO DTE
+3 if $GET(PSSCOUT)
QUIT
+4 SET (FLAG,PSSCFLAG)=0
+5 FOR ZZ=0:0
SET ZZ=$ORDER(^PS(52.6,"AOI",PSSREST,ZZ))
if 'ZZ!($GET(PSSCOUT))
QUIT
if ($Y+5)>IOSL
DO DHEAD
if $GET(PSSCOUT)
QUIT
IF ZZ
Begin DoDot:1
+6 SET (PSSCFLAG,PSSCXXX)=1
+7 WRITE !,$PIECE($GET(^PS(52.6,ZZ,0)),"^"),?42,"(A)"
+8 SET PSSCDATE=$PIECE($GET(^PS(52.6,ZZ,"I")),"^")
IF PSSCDATE
DO DTEX
End DoDot:1
+9 if $GET(PSSCOUT)
QUIT
+10 ;I $G(PSSCFLAG) W !
+11 FOR ZZ=0:0
SET ZZ=$ORDER(^PS(52.7,"AOI",PSSREST,ZZ))
if 'ZZ!($GET(PSSCOUT))
QUIT
if ($Y+5)>IOSL
DO DHEAD
if $GET(PSSCOUT)
QUIT
IF ZZ
Begin DoDot:1
+12 WRITE !,$PIECE($GET(^PS(52.7,ZZ,0)),"^"),?31,$PIECE($GET(^(0)),"^",3),?42,"(S)"
+13 SET PSSCDATE=$PIECE($GET(^PS(52.7,ZZ,"I")),"^")
IF PSSCDATE
DO DTEX
End DoDot:1
+14 QUIT
DHEAD IF 'FLAG
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
IF 'Y
SET PSSCOUT=1
QUIT
+1 WRITE @IOF
WRITE !,?6,"Orderable Item -> ",$PIECE($GET(^PS(50.7,PSSREST,0)),"^"),!?6,"Dosage Form -> ",$PIECE($GET(^PS(50.606,+$PIECE($GET(^PS(50.7,PSSREST,0)),"^",2),0)),"^"),!!,"Dispense Drugs:"_$SELECT('FLAG:" (continued)",1:""),!,"---------------
"
+2 QUIT
DTE IF $DATA(^PSDRUG(ZZ,"I"))
SET Y=$PIECE(^PSDRUG(ZZ,"I"),"^")
DO DD^%DT
WRITE ?50,Y
KILL Y
+1 QUIT
DTEX SET Y=$GET(PSSCDATE)
DO DD^%DT
WRITE ?50,$GET(Y)
KILL Y
+1 QUIT
NONFORM ;
+1 ;formulary status of Orderable Item
+2 if '$GET(PSSORDIT)
QUIT
+3 NEW PSNFX,PSNFX1,PSNFX2,PSNFXB
+4 SET (PSNFX1,PSNFX2)=0
+5 SET PSNFXB=$PIECE($GET(^PS(50.7,PSSORDIT,0)),"^",12)
+6 FOR PSNFX=0:0
SET PSNFX=$ORDER(^PS(50.7,"A50",PSSORDIT,PSNFX))
if 'PSNFX
QUIT
Begin DoDot:1
+7 IF $PIECE($GET(^PSDRUG(PSNFX,2)),"^",3)'["O"
IF $PIECE($GET(^(2)),"^",3)'["I"
IF $PIECE($GET(^(2)),"^",3)'["U"
IF $PIECE($GET(^(2)),"^",3)'["X"
QUIT
+8 IF $PIECE($GET(^PSDRUG(PSNFX,"I")),"^")
IF $PIECE($GET(^("I")),"^")'>DT
QUIT
+9 IF $PIECE($GET(^PSDRUG(PSNFX,0)),"^",9)=1
SET PSNFX1=1
QUIT
+10 SET PSNFX2=1
End DoDot:1
+11 IF PSNFX1
IF 'PSNFX2
SET $PIECE(^PS(50.7,PSSORDIT,0),"^",12)=1
+12 IF PSNFX2
SET $PIECE(^PS(50.7,PSSORDIT,0),"^",12)=""
+13 IF $PIECE($GET(^PS(50.7,PSSORDIT,0)),"^",12)'=$GET(PSNFXB)
IF '$GET(PSSCROSS)
Begin DoDot:1
+14 WRITE !!,"The Formulary Status of the Pharmacy Orderable Item",!,$PIECE($GET(^PS(50.7,PSSORDIT,0)),"^")_" "_...
... $PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^"),!,"has been changed to "_$SELECT($PIECE($GET(^PS(50.7,PSSORDIT,0)),"^",12):"Non-Formulary.",1:"Formulary."),!
End DoDot:1
+15 QUIT
MSSG IF '$GET(PSSCROSS)
WRITE !!,"This Orderable Item is "_$SELECT($PIECE($GET(^PS(50.7,PSSORDIT,0)),"^",12):"Non-Formulary.",1:"Formulary."),!
+1 QUIT
NONVA ; Evaluates the Non-VA Med Indicator of the Orderable Item
+1 NEW PSNVADG,PSNONVA,PSDRG
+2 ;
+3 if '$GET(PSSORDIT)
QUIT
+4 SET PSNVADG=0
SET PSNONVA=$PIECE($GET(^PS(50.7,PSSORDIT,0)),"^",10)
SET PSDRG=0
+5 FOR
SET PSDRG=$ORDER(^PS(50.7,"A50",PSSORDIT,PSDRG))
if 'PSDRG!(PSNVADG)
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^PSDRUG(PSDRG,"I")),"^")
IF $PIECE($GET(^("I")),"^")'>DT
QUIT
+7 IF $PIECE($GET(^PSDRUG(PSDRG,2)),"^",3)["X"
SET PSNVADG=1
End DoDot:1
+8 ;
+9 IF PSNVADG
SET $PIECE(^PS(50.7,PSSORDIT,0),"^",10)=1
+10 IF 'PSNVADG
SET $PIECE(^PS(50.7,PSSORDIT,0),"^",10)=""
+11 ;
+12 IF +$PIECE($GET(^PS(50.7,PSSORDIT,0)),"^",10)'=+PSNONVA
IF '$GET(PSSCROSS)
Begin DoDot:1
+13 WRITE !!,"The Pharmacy Orderable Item ",$PIECE($GET(^PS(50.7,PSSORDIT,0)),"^")
+14 WRITE !,"is ",$SELECT('PSNONVA:"now",1:"no longer")," marked as a NON-VA MED Drug."
End DoDot:1
+15 QUIT
