PSSUTLPZ ;BIR/RTR-Pre release report utility routine ;02/14/00
;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
;
TEXT ;Text for pre-release report
W !!,"The current Orderable Item structure keeps Additives and Solutions matched to",!,"Orderable Items flagged for IV use. All Dispense Drugs are currently matched to",!,"Orderable Items that are not flagged for IV Use. This was done"
W " to control "
W !,"the finishing process of IV and Unit Dose orders entered through CPRS.",!,"The new Orderable Item structure will inactivate all IV flagged Orderable",!,"Items. All Additives and Solutions will be re-matched to non-IV flagged"
W !,"Orderable Items, based on their Dispense Drug links.",!
W ! K DIR S DIR(0)="E" D ^DIR K DIR I Y["^"!($D(DIRUT)) K Y S PSSOUT=1 Q
K PSSTYPE
K DIR S DIR(0)="S^A:ADDITIVES;S:SOLUTIONS;B:BOTH",DIR("A")="Print report for Additives, Solutions, or Both",DIR("B")="B"
S DIR("?")=" ",DIR("?",1)="Enter 'A' to see how the Additives will be re-matched in the new Orderable"
S DIR("?",2)="Item structure, enter 'S' to see how the Solutions will be re-matched in the",DIR("?",3)="new Orderable Item structure, enter 'B' to see both, enter '^' to exit."
Q
INS ;Convert non-numeric Instructions to Nouns
D CHECK I $G(PSSNOCON) K PSSNOCON Q
K PSSNOCON
W !!,"This option will move all non-numeric Instructions to the Noun field in the",!,"Dosage Form file. If you do this, you will then need to review the Nouns and decide to mark them for Inpatient, Outpatient or both."
W ! K DIR S DIR(0)="Y",DIR("A")="Convert all non-numeric Instructions to Nouns",DIR("B")="Y" D ^DIR I Y'=1 W !!,"Nothing converted.",! G INSQ
W !,"Converting.." H 1
N PSSD,PSSI,PSSINS
F PSSD=0:0 S PSSD=$O(^PS(50.606,PSSD)) Q:'PSSD D:$O(^PS(50.606,PSSD,"INS",0))
.F PSSI=0:0 S PSSI=$O(^PS(50.606,PSSD,"INS",PSSI)) Q:'PSSI S PSSINS=$P($G(^PS(50.606,PSSD,"INS",PSSI,0)),"^") I PSSINS'="" D
..I PSSINS?.N!(PSSINS?.N1".".N) Q
..I $O(^PS(50.606,PSSD,"NOUN","B",PSSINS,0)) Q
..K DIC,DD,DO S DA(1)=PSSD,DIC="^PS(50.606,"_DA(1)_",""NOUN"",",DIC(0)="L",X=PSSINS D FILE^DICN W "." K DD,DO,DIC
W !,"Finished converting Instructions to Nouns!"
INSQ W !
Q
NOUN ;Enter/edit Nouns
D CHECK I $G(PSSNOCON) K PSSNOCON G NOUNQ
K PSSNOCON
W ! K DIC S DIC(0)="QEAMZ",DIC="^PS(50.606," D ^DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G NOUNQ
S PSSDOSE=+Y
NOUNA W !!?2,"Dosage Form => ",$P($G(^PS(50.606,+PSSDOSE,0)),"^"),! K DIC S DA(1)=PSSDOSE,DIC="^PS(50.606,"_PSSDOSE_",""NOUN"",",DIC(0)="QEAMLZ" D D ^DIC I Y<1!($D(DUOUT))!($D(DTOUT)) G NOUNC
.S DIC("W")="W "" ""_$P($G(^PS(50.606,PSSDOSE,""NOUN"",+Y,0)),""^"",2)"
S PSSNOUN=+Y
K DIE S DA(1)=PSSDOSE,DA=PSSNOUN,DR=".01;1;2",DIE="^PS(50.606,"_PSSDOSE_",""NOUN""," D ^DIE K DIE G:'$D(Y)&('$D(DTOUT)) NOUNA
NOUNC W ! K DIE S DA=PSSDOSE,DIE="^PS(50.606,",DR="10" D ^DIE K DIE G NOUN
NOUNQ W ! K DIC,DR,DIE,PSSDOSE,PSSNOUN
Q
CHECK ;Check for running conversion
S PSSNOCON=0
S PSSYSIEN=$O(^PS(59.7,0))
I $P($G(^PS(59.7,+$G(PSSYSIEN),80)),"^",3)=2 S PSSNOCON=1
K PSSYSIEN I PSSNOCON W $C(7) W !!,"Cannot use this option, Dosage conversion is currently running!",!
Q
TRAC ;
N PSZZ,PSZZ1,PSZZ2,PSZSTA,PSZSTO,PSZWHO
S PSZZ1=$O(^PS(59.7,0)),PSZZ2=$P($G(^PS(59.7,+$G(PSZZ1),80)),"^",3)
I PSZZ2 D
.S Y=$P($G(^PS(59.7,+$G(PSZZ1),80)),"^",4) I Y D DD^%DT S PSZSTA=$G(Y)
.S Y=$P($G(^PS(59.7,+$G(PSZZ1),80)),"^",5) I Y D DD^%DT S PSZSTO=$G(Y)
.K PSZWHOAR S DA=+$P($G(^PS(59.7,+$G(PSZZ1),80)),"^",6) I DA S DIC=200,DR=".01",DIQ(0)="E",DIQ="PSZWHOAR" D EN^DIQ1 S PSZWHO=$G(PSZWHOAR(200,DA,.01,"E")) K DIQ,PSZWHOAR,DR,DIC,DA
H 1 W @IOF W !,?15,"Dosage Conversion Tracker Status",! F PSZZ=1:1:77 W "="
I 'PSZZ2 W !,"The Dosage conversion has never been run!",! G TRACQ
I PSZZ2=1 W !,"The Dosage conversion is queued to run at "_$G(PSZSTA),!,"It was queued by "_$G(PSZWHO),! G TRACQ
I PSZZ2=2 W !,"The Dosage conversion is currently running.",!,"It started at "_$G(PSZSTA),! G TRACQ
I PSZZ2=3 W !,"The Dosage conversion was last run by "_$G(PSZWHO),!,"It started on "_$G(PSZSTA)_" and ended on "_$G(PSZSTO),!
TRACQ W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR W ! K DIR
Q
FRE ;
W ! K DIC S DIC(0)="QEAMZ",DIC("A")="Select Medication Instruction: ",DIC="^PS(51," D ^DIC K DIC I Y<1!($D(DTOUT))!($D(DUOUT)) G FREQ
K DIE W ! S DA=+Y,DIE="^PS(51,",DR="31" D ^DIE G:$D(Y)!($D(DTOUT)) FREQ
G FRE
FREQ W ! K DA,DIE,DR,DIC
Q
FRRP ;
W !!,"This report shows the MEDICATION INSTRUCTION file entries, along with the",!,"Synonym, Frequency and Expansion. Use the Edit Medication Instruction",!,"Frequency option to enter appropriate frequencies.",!
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",!! Q
I $D(IO("Q")) S ZTRTN="ENF^PSSUTLPR",ZTDESC="Med Instruction Frequency report" D ^%ZTLOAD K %ZIS W !,"Report queued to print." Q
ENF ;
U IO
S PSSOUT=0,PSSDV=$S($E(IOST)="C":"C",1:"P"),PSSCT=1
K PSSLINE,PSSF,PSSFR S $P(PSSLINE,"-",79)=""
D ENFH
S PSSF="" F S PSSF=$O(^PS(51,"B",PSSF)) Q:PSSF=""!($G(PSSOUT)) F PSSFR=0:0 S PSSFR=$O(^PS(51,"B",PSSF,PSSFR)) Q:'PSSFR!($G(PSSOUT)) I $G(^PS(51,"B",PSSF,PSSFR))="" D
.I ($Y+5)>IOSL D ENFH Q:$G(PSSOUT)
.S PSSFNODE=$G(^PS(51,PSSFR,0)) Q:PSSFNODE=""
.W !,$P(PSSFNODE,"^"),?11,$P(PSSFNODE,"^",3),?22,$P(PSSFNODE,"^",8),?30,$P(PSSFNODE,"^",2)
I '$G(PSSOUT),$G(PSSDV)="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $G(PSSDV)="C" W !
E W @IOF
K PSSLINE,PSSOUT,PSSF,PSSFR,PSSCT,PSSDV D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
ENFH ;
I $G(PSSDV)="C",$G(PSSCT)'=1 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSOUT=1 Q
W @IOF W !?5,"MEDICATION INSTRUCTION FREQUENCY REPORT"_$S($G(PSSCT)=1:"",1:" (cont.)"),?68,"PAGE: "_$G(PSSCT) S PSSCT=PSSCT+1
W !!,"NAME",?10,"SYNONYM",?21,"FREQUENCY",?34,"EXPANSION",!,PSSLINE,!
Q
SLS ;Called from PSSORUTL
K PSSJZUNT
I $P($G(PSSX(PSSA,PL3)),"^",2)'["/" S $P(PSSX(PSSA,PL3),"^",5)=$P($G(PSSX(PSSA,PL3)),"^")_$P($G(PSSX(PSSA,PL3)),"^",2) Q
N PSSJ,PSSJ1,PSSJ2,PSSI,PSSJA,PSSJA1,PSSJB,PSSJB1,PSSWZI,PSSWZSL,PSSWZND,PSSWZSL1,PSSWZSL2,PSSWZSL3,PSSWZSL4,PSSWZSL5,PSSWZ50
S PSSJ=$P($G(PSSX(PSSA,PL3)),"^"),PSSI=$P($G(PSSX(PSSA,PL3)),"^",2)
S PSSWZSL=0,PSSWZI=+$P($G(PSSX(PSSA,PL3)),"^",6),PSSWZ50=$P($G(^PSDRUG(PSSWZI,"DOS")),"^")
S PSSWZND=$$PSJST^PSNAPIS(+$P($G(^PSDRUG(PSSWZI,"ND")),"^"),+$P($G(^PSDRUG(PSSWZI,"ND")),"^",3)) S PSSWZND=+$P($G(PSSWZND),"^",2) ;I $G(PSSWZND),$G(PSSWZ50),+$G(PSSWZND)'=+$G(PSSWZ50) S PSSWZSL=1
S PSSJA=$P(PSSI,"/"),PSSJB=$P(PSSI,"/",2),PSSJA1=+$G(PSSJA),PSSJB1=+$G(PSSJB)
I '$G(PSSWZND) S $P(PSSX(PSSA,PL3),"^",5)=$P(PSSX(PSSA,PL3),"^") G SLSQ
S PSSWZSL2=PSSWZ50/PSSWZND,PSSWZSL3=PSSWZSL2*+$P($G(PSSX(PSSA,PL3)),"^",3) S PSSWZSL4=PSSWZSL3*$S($G(PSSJB1):PSSJB1,1:1) S PSSWZSL5=$S('$G(PSSJB1):PSSWZSL4_$G(PSSJB),1:PSSWZSL4_$P(PSSJB,PSSJB1,2))
S PSSJ2=$S('$G(PSSJA1):PSSJ,1:($G(PSSJA1)*PSSJ))_$S($G(PSSJA1):$P(PSSJA,PSSJA1,2),1:PSSJA)_"/"_$G(PSSWZSL5)
S PSSJZUNT=$P(PSSI,"/")_"/"_$G(PSSWZSL4)_$S('$G(PSSJB1):$G(PSSJB),1:$P(PSSJB,PSSJB1,2)) S $P(PSSX(PSSA,PL3),"^",2)=PSSJZUNT
S $P(PSSX(PSSA,PL3),"^",5)=PSSJ2
SLSQ Q
;
ADDRP ;
D ^DIR K DIR S PSSTYPE=Y I Y["^"!($D(DIRUT)) K PSSTYPE W ! Q
W !!?3,"*** THIS REPORT IS DESIGNED FOR 132 COLUMNS ***",!
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) W !,"Nothing queued to print.",! K PSSTYPE W ! Q
I '$G(DT) S DT=$$DT^XLFDT
S X1=DT,X2=-365 D C^%DTC S PSSYRX=$G(X) K X,X1,X2
I $D(IO("Q")) S ZTRTN="ADD^PSSREMCH",ZTDESC="Orderable Item re-matching report",ZTSAVE("PSSTYPE")="",ZTSAVE("PSSYRX")="" D ^%ZTLOAD K %ZIS W !,"Report queued to print." G END^PSSREMCH
G ADD^PSSREMCH
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSUTLPZ 7741 printed Oct 16, 2024@18:35:22 Page 2
PSSUTLPZ ;BIR/RTR-Pre release report utility routine ;02/14/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
+2 ;
TEXT ;Text for pre-release report
+1 WRITE !!,"The current Orderable Item structure keeps Additives and Solutions matched to",!,"Orderable Items flagged for IV use. All Dispense Drugs are currently matched to",!,"Orderable Items that are not flagged for IV Use. This was done"
+2 WRITE " to control "
+3 WRITE !,"the finishing process of IV and Unit Dose orders entered through CPRS.",!,"The new Orderable Item structure will inactivate all IV flagged Orderable",!,"Items. All Additives and Solutions will be re-matched to non-IV flagged"
+4 WRITE !,"Orderable Items, based on their Dispense Drug links.",!
+5 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DIRUT))
KILL Y
SET PSSOUT=1
QUIT
+6 KILL PSSTYPE
+7 KILL DIR
SET DIR(0)="S^A:ADDITIVES;S:SOLUTIONS;B:BOTH"
SET DIR("A")="Print report for Additives, Solutions, or Both"
SET DIR("B")="B"
+8 SET DIR("?")=" "
SET DIR("?",1)="Enter 'A' to see how the Additives will be re-matched in the new Orderable"
+9 SET DIR("?",2)="Item structure, enter 'S' to see how the Solutions will be re-matched in the"
SET DIR("?",3)="new Orderable Item structure, enter 'B' to see both, enter '^' to exit."
+10 QUIT
INS ;Convert non-numeric Instructions to Nouns
+1 DO CHECK
IF $GET(PSSNOCON)
KILL PSSNOCON
QUIT
+2 KILL PSSNOCON
+3 WRITE !!,"This option will move all non-numeric Instructions to the Noun field in the",!,"Dosage Form file. If you do this, you will then need to review the Nouns and decide to mark them for Inpatient, Outpatient or both."
+4 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Convert all non-numeric Instructions to Nouns"
SET DIR("B")="Y"
DO ^DIR
IF Y'=1
WRITE !!,"Nothing converted.",!
GOTO INSQ
+5 WRITE !,"Converting.."
HANG 1
+6 NEW PSSD,PSSI,PSSINS
+7 FOR PSSD=0:0
SET PSSD=$ORDER(^PS(50.606,PSSD))
if 'PSSD
QUIT
if $ORDER(^PS(50.606,PSSD,"INS",0))
Begin DoDot:1
+8 FOR PSSI=0:0
SET PSSI=$ORDER(^PS(50.606,PSSD,"INS",PSSI))
if 'PSSI
QUIT
SET PSSINS=$PIECE($GET(^PS(50.606,PSSD,"INS",PSSI,0)),"^")
IF PSSINS'=""
Begin DoDot:2
+9 IF PSSINS?.N!(PSSINS?.N1".".N)
QUIT
+10 IF $ORDER(^PS(50.606,PSSD,"NOUN","B",PSSINS,0))
QUIT
+11 KILL DIC,DD,DO
SET DA(1)=PSSD
SET DIC="^PS(50.606,"_DA(1)_",""NOUN"","
SET DIC(0)="L"
SET X=PSSINS
DO FILE^DICN
WRITE "."
KILL DD,DO,DIC
End DoDot:2
End DoDot:1
+12 WRITE !,"Finished converting Instructions to Nouns!"
INSQ WRITE !
+1 QUIT
NOUN ;Enter/edit Nouns
+1 DO CHECK
IF $GET(PSSNOCON)
KILL PSSNOCON
GOTO NOUNQ
+2 KILL PSSNOCON
+3 WRITE !
KILL DIC
SET DIC(0)="QEAMZ"
SET DIC="^PS(50.606,"
DO ^DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
GOTO NOUNQ
+4 SET PSSDOSE=+Y
NOUNA WRITE !!?2,"Dosage Form => ",$PIECE($GET(^PS(50.606,+PSSDOSE,0)),"^"),!
KILL DIC
SET DA(1)=PSSDOSE
SET DIC="^PS(50.606,"_PSSDOSE_",""NOUN"","
SET DIC(0)="QEAMLZ"
Begin DoDot:1
+1 SET DIC("W")="W "" ""_$P($G(^PS(50.606,PSSDOSE,""NOUN"",+Y,0)),""^"",2)"
End DoDot:1
DO ^DIC
IF Y<1!($DATA(DUOUT))!($DATA(DTOUT))
GOTO NOUNC
+2 SET PSSNOUN=+Y
+3 KILL DIE
SET DA(1)=PSSDOSE
SET DA=PSSNOUN
SET DR=".01;1;2"
SET DIE="^PS(50.606,"_PSSDOSE_",""NOUN"","
DO ^DIE
KILL DIE
if '$DATA(Y)&('$DATA(DTOUT))
GOTO NOUNA
NOUNC WRITE !
KILL DIE
SET DA=PSSDOSE
SET DIE="^PS(50.606,"
SET DR="10"
DO ^DIE
KILL DIE
GOTO NOUN
NOUNQ WRITE !
KILL DIC,DR,DIE,PSSDOSE,PSSNOUN
+1 QUIT
CHECK ;Check for running conversion
+1 SET PSSNOCON=0
+2 SET PSSYSIEN=$ORDER(^PS(59.7,0))
+3 IF $PIECE($GET(^PS(59.7,+$GET(PSSYSIEN),80)),"^",3)=2
SET PSSNOCON=1
+4 KILL PSSYSIEN
IF PSSNOCON
WRITE $CHAR(7)
WRITE !!,"Cannot use this option, Dosage conversion is currently running!",!
+5 QUIT
TRAC ;
+1 NEW PSZZ,PSZZ1,PSZZ2,PSZSTA,PSZSTO,PSZWHO
+2 SET PSZZ1=$ORDER(^PS(59.7,0))
SET PSZZ2=$PIECE($GET(^PS(59.7,+$GET(PSZZ1),80)),"^",3)
+3 IF PSZZ2
Begin DoDot:1
+4 SET Y=$PIECE($GET(^PS(59.7,+$GET(PSZZ1),80)),"^",4)
IF Y
DO DD^%DT
SET PSZSTA=$GET(Y)
+5 SET Y=$PIECE($GET(^PS(59.7,+$GET(PSZZ1),80)),"^",5)
IF Y
DO DD^%DT
SET PSZSTO=$GET(Y)
+6 KILL PSZWHOAR
SET DA=+$PIECE($GET(^PS(59.7,+$GET(PSZZ1),80)),"^",6)
IF DA
SET DIC=200
SET DR=".01"
SET DIQ(0)="E"
SET DIQ="PSZWHOAR"
DO EN^DIQ1
SET PSZWHO=$GET(PSZWHOAR(200,DA,.01,"E"))
KILL DIQ,PSZWHOAR,DR,DIC,DA
End DoDot:1
+7 HANG 1
WRITE @IOF
WRITE !,?15,"Dosage Conversion Tracker Status",!
FOR PSZZ=1:1:77
WRITE "="
+8 IF 'PSZZ2
WRITE !,"The Dosage conversion has never been run!",!
GOTO TRACQ
+9 IF PSZZ2=1
WRITE !,"The Dosage conversion is queued to run at "_$GET(PSZSTA),!,"It was queued by "_$GET(PSZWHO),!
GOTO TRACQ
+10 IF PSZZ2=2
WRITE !,"The Dosage conversion is currently running.",!,"It started at "_$GET(PSZSTA),!
GOTO TRACQ
+11 IF PSZZ2=3
WRITE !,"The Dosage conversion was last run by "_$GET(PSZWHO),!,"It started on "_$GET(PSZSTA)_" and ended on "_$GET(PSZSTO),!
TRACQ WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
WRITE !
KILL DIR
+1 QUIT
FRE ;
+1 WRITE !
KILL DIC
SET DIC(0)="QEAMZ"
SET DIC("A")="Select Medication Instruction: "
SET DIC="^PS(51,"
DO ^DIC
KILL DIC
IF Y<1!($DATA(DTOUT))!($DATA(DUOUT))
GOTO FREQ
+2 KILL DIE
WRITE !
SET DA=+Y
SET DIE="^PS(51,"
SET DR="31"
DO ^DIE
if $DATA(Y)!($DATA(DTOUT))
GOTO FREQ
+3 GOTO FRE
FREQ WRITE !
KILL DA,DIE,DR,DIC
+1 QUIT
FRRP ;
+1 WRITE !!,"This report shows the MEDICATION INSTRUCTION file entries, along with the",!,"Synonym, Frequency and Expansion. Use the Edit Medication Instruction",!,"Frequency option to enter appropriate frequencies.",!
+2 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!!
QUIT
+3 IF $DATA(IO("Q"))
SET ZTRTN="ENF^PSSUTLPR"
SET ZTDESC="Med Instruction Frequency report"
DO ^%ZTLOAD
KILL %ZIS
WRITE !,"Report queued to print."
QUIT
ENF ;
+1 USE IO
+2 SET PSSOUT=0
SET PSSDV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
SET PSSCT=1
+3 KILL PSSLINE,PSSF,PSSFR
SET $PIECE(PSSLINE,"-",79)=""
+4 DO ENFH
+5 SET PSSF=""
FOR
SET PSSF=$ORDER(^PS(51,"B",PSSF))
if PSSF=""!($GET(PSSOUT))
QUIT
FOR PSSFR=0:0
SET PSSFR=$ORDER(^PS(51,"B",PSSF,PSSFR))
if 'PSSFR!($GET(PSSOUT))
QUIT
IF $GET(^PS(51,"B",PSSF,PSSFR))=""
Begin DoDot:1
+6 IF ($Y+5)>IOSL
DO ENFH
if $GET(PSSOUT)
QUIT
+7 SET PSSFNODE=$GET(^PS(51,PSSFR,0))
if PSSFNODE=""
QUIT
+8 WRITE !,$PIECE(PSSFNODE,"^"),?11,$PIECE(PSSFNODE,"^",3),?22,$PIECE(PSSFNODE,"^",8),?30,$PIECE(PSSFNODE,"^",2)
End DoDot:1
+9 IF '$GET(PSSOUT)
IF $GET(PSSDV)="C"
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+10 IF $GET(PSSDV)="C"
WRITE !
+11 IF '$TEST
WRITE @IOF
+12 KILL PSSLINE,PSSOUT,PSSF,PSSFR,PSSCT,PSSDV
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+13 QUIT
ENFH ;
+1 IF $GET(PSSDV)="C"
IF $GET(PSSCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+2 WRITE @IOF
WRITE !?5,"MEDICATION INSTRUCTION FREQUENCY REPORT"_$SELECT($GET(PSSCT)=1:"",1:" (cont.)"),?68,"PAGE: "_$GET(PSSCT)
SET PSSCT=PSSCT+1
+3 WRITE !!,"NAME",?10,"SYNONYM",?21,"FREQUENCY",?34,"EXPANSION",!,PSSLINE,!
+4 QUIT
SLS ;Called from PSSORUTL
+1 KILL PSSJZUNT
+2 IF $PIECE($GET(PSSX(PSSA,PL3)),"^",2)'["/"
SET $PIECE(PSSX(PSSA,PL3),"^",5)=$PIECE($GET(PSSX(PSSA,PL3)),"^")_$PIECE($GET(PSSX(PSSA,PL3)),"^",2)
QUIT
+3 NEW PSSJ,PSSJ1,PSSJ2,PSSI,PSSJA,PSSJA1,PSSJB,PSSJB1,PSSWZI,PSSWZSL,PSSWZND,PSSWZSL1,PSSWZSL2,PSSWZSL3,PSSWZSL4,PSSWZSL5,PSSWZ50
+4 SET PSSJ=$PIECE($GET(PSSX(PSSA,PL3)),"^")
SET PSSI=$PIECE($GET(PSSX(PSSA,PL3)),"^",2)
+5 SET PSSWZSL=0
SET PSSWZI=+$PIECE($GET(PSSX(PSSA,PL3)),"^",6)
SET PSSWZ50=$PIECE($GET(^PSDRUG(PSSWZI,"DOS")),"^")
+6 ;I $G(PSSWZND),$G(PSSWZ50),+$G(PSSWZND)'=+$G(PSSWZ50) S PSSWZSL=1
SET PSSWZND=$$PSJST^PSNAPIS(+$PIECE($GET(^PSDRUG(PSSWZI,"ND")),"^"),+$PIECE($GET(^PSDRUG(PSSWZI,"ND")),"^",3))
SET PSSWZND=+$PIECE($GET(PSSWZND),"^",2)
+7 SET PSSJA=$PIECE(PSSI,"/")
SET PSSJB=$PIECE(PSSI,"/",2)
SET PSSJA1=+$GET(PSSJA)
SET PSSJB1=+$GET(PSSJB)
+8 IF '$GET(PSSWZND)
SET $PIECE(PSSX(PSSA,PL3),"^",5)=$PIECE(PSSX(PSSA,PL3),"^")
GOTO SLSQ
+9 SET PSSWZSL2=PSSWZ50/PSSWZND
SET PSSWZSL3=PSSWZSL2*+$PIECE($GET(PSSX(PSSA,PL3)),"^",3)
SET PSSWZSL4=PSSWZSL3*$SELECT($GET(PSSJB1):PSSJB1,1:1)
SET PSSWZSL5=$SELECT('$GET(PSSJB1):PSSWZSL4_$GET(PSSJB),1:PSSWZSL4_$PIECE(PSSJB,PSSJB1,2))
+10 SET PSSJ2=$SELECT('$GET(PSSJA1):PSSJ,1:($GET(PSSJA1)*PSSJ))_$SELECT($GET(PSSJA1):$PIECE(PSSJA,PSSJA1,2),1:PSSJA)_"/"_$GET(PSSWZSL5)
+11 SET PSSJZUNT=$PIECE(PSSI,"/")_"/"_$GET(PSSWZSL4)_$SELECT('$GET(PSSJB1):$GET(PSSJB),1:$PIECE(PSSJB,PSSJB1,2))
SET $PIECE(PSSX(PSSA,PL3),"^",2)=PSSJZUNT
+12 SET $PIECE(PSSX(PSSA,PL3),"^",5)=PSSJ2
SLSQ QUIT
+1 ;
ADDRP ;
+1 DO ^DIR
KILL DIR
SET PSSTYPE=Y
IF Y["^"!($DATA(DIRUT))
KILL PSSTYPE
WRITE !
QUIT
+2 WRITE !!?3,"*** THIS REPORT IS DESIGNED FOR 132 COLUMNS ***",!
+3 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !,"Nothing queued to print.",!
KILL PSSTYPE
WRITE !
QUIT
+4 IF '$GET(DT)
SET DT=$$DT^XLFDT
+5 SET X1=DT
SET X2=-365
DO C^%DTC
SET PSSYRX=$GET(X)
KILL X,X1,X2
+6 IF $DATA(IO("Q"))
SET ZTRTN="ADD^PSSREMCH"
SET ZTDESC="Orderable Item re-matching report"
SET ZTSAVE("PSSTYPE")=""
SET ZTSAVE("PSSYRX")=""
DO ^%ZTLOAD
KILL %ZIS
WRITE !,"Report queued to print."
GOTO END^PSSREMCH
+7 GOTO ADD^PSSREMCH
