- 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 Jan 18, 2025@03:34:39 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