PSSWRNB ;BIR/EJW-NEW WARNING SOURCE CUSTOM WARNING LIST BUILDER ; 9/8/05 3:46pm
;;1.0;PHARMACY DATA MANAGEMENT;**87,98,144**;9/30/97;Build 13
;
;IA: 3735 ^PSNDF(50.68
;IA: 4445 ^PS(50.625
;IA: 4446 ^PS(50.626
;IA: 4448 ^PS(50.627
D NOTE^PSSWRNE,NOTE2^PSSWRNE
W ! K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")=" Would you like to print a list of the entries in these files" D ^DIR K DIR I Y["^"!($D(DTOUT)) W !!?3,"Nothing queued to print." G SEL
I 'Y G SEL
S SPANISH=0
W ! K DIR S DIR(0)="Y",DIR("B")="N",DIR("A")=" Would you like to include the Spanish translations" D ^DIR K DIR I Y["^"!($D(DTOUT)) W !!?3,"Nothing queued to print." G SEL
I Y S SPANISH=1
D RPT
SEL ;
W @IOF
D NOTE^PSSWRNE
W !!,?2,"Select one of the following to display drugs that match that criteria to"
W !,?2,"examine or edit their drug warnings:"
K DIR
S DIR("B")=""
S DIR("A")="Enter selection or '^' to exit: "
S DIR("A",1)="1. Drug has WARNING LABEL filled in but there are no FDB warnings for the drug"
S DIR("A",2)="2. Drug has WARNING LABEL numbers higher than 20"
S DIR("A",3)="3. Select by range of drug names"
S DIR("A",4)="4. Drug has more than 5 warning labels"
S DIR("A",5)="5. Drugs containing specific WARNING LABEL number"
S DIR("A",6)="6. Drug has WARNING LABEL that does not map to new data source"
S DIR("A",7)="7. Drugs containing specific new data source warning number"
S DIR("A",8)="8. Drugs containing gender-specific warnings"
S DIR("A",9)="9. Drugs with warning mapping, but drug doesn't contain ""mapped to"" number"
S DIR(0)="SA^1:DRUGS WITH NO FDB WARNINGS;2:LOCAL WARNING (>20);3:RANGE OF DRUG NAMES;4:GREATER THAN 5 WARNINGS;5:SPECIFIC WARNING LABEL NUMBER;6:NO MAPPING;7:SPECIFIC NEW WARNING;8:GENDER-SPECIFIC WARNING;9:NO MAPPED TO"
D ^DIR K DIR S SEL=Y
I 'SEL G KILL
N DR,ACTIVE,SKIP,QUIT,PSO9
S SKIP=1,QUIT=0
K ^TMP("PSSWRNB",$J)
ASK K DIR W ! S DIR(0)="Y",DIR("B")="Y",DIR("A")="Exclude drugs with NEW WARNING LABEL LIST filled in" D ^DIR K DIR I Y["^"!($D(DTOUT)) G SEL
I 'Y S SKIP=0
W !!,$C(7),"NOTE: Only the first 5 warnings will print on the yellow auxillary labels."
K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to see the warning text for all warnings" D ^DIR K DIR I Y["^"!($D(DTOUT)) G SEL
S ENDWARN=5
I Y S ENDWARN=99 D
.W !," Warnings (>5) that won't print and won't be sent to CMOP"
.W !," will be marked with a ""*"" on the following screens."
W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1 Q
;
I SEL=1 D SEL1^PSSWRNC
;
I SEL=2 D SEL2^PSSWRNC
;
I SEL=3 D SEL3^PSSWRNC
;
I SEL=4 D SEL4^PSSWRNC
;
I SEL=5!(SEL=9) D SEL59^PSSWRNC
;
I SEL=6 D SEL6^PSSWRNC
;
I SEL=7 D SEL7^PSSWRNC
;
I SEL=8 D SEL8^PSSWRNC
;
I 'QUIT I '$D(^TMP("PSSWRNB",$J)) W !,"Nothing meets selection criteria" H 2 S QUIT=1
I 'QUIT D EDIT^PSSWRNE
G SEL
RPT ;
RPTQ W !!,"You may queue the report to print, if you wish.",!
;
DVC K %ZIS,POP,IOP S %ZIS="QM" D ^%ZIS I $G(POP) W !,"Nothing queued to print.",! G DONE
S ZTSAVE("*")=""
I $D(IO("Q")) S ZTRTN="PRT54^PSSWRNB",ZTDESC="WARNING LABEL TEXT REPORTS" D ^%ZTLOAD K %ZIS W !,"Report queued to print.",! G DONE
PRT54 ;
U IO
S PSSOUT=0,PSSDV=$S($E(IOST,1,2)="C-":"C",1:"P")
S PSSPGCT=0,PSSPGLN=IOSL-7,PSSPGCT=1
S TITLE="RX CONSULT file - WARNING LABEL TEXT"
D TITLE
;
S SEQ=0 F S SEQ=$O(^PS(54,SEQ)) Q:'SEQ D PRTRPT
G END
PRTRPT ;
I $G(^PS(54,SEQ,0))'="" D RXCON D FULL I $G(PSSOUT) Q
D FULL I $G(PSSOUT) Q
W ! F MJT=1:1:70 W "-"
Q
RXCON D FULL Q:$G(PSSOUT) W !,"RX CONSULT NUMBER: ",SEQ
N PSSTXT
D FULL I $G(PSSOUT) Q
W !
S PSSTXT=0 F S PSSTXT=$O(^PS(54,SEQ,1,PSSTXT)) Q:'PSSTXT D FULL Q:$G(PSSOUT) W !,?3,^PS(54,SEQ,1,PSSTXT,0)
I $G(SPANISH),$D(^PS(54,SEQ,3)) W !!,"Spanish translation:" D
.S PSSTXT=^PS(54,SEQ,3) Q:PSSTXT="" D FULL Q:$G(PSSOUT) W !,?3 D
..N LEN,I,STR
..S LEN=0
..F I=1:1:$L(PSSTXT," ") S STR=$P(PSSTXT," ",I),LEN=LEN+$L(STR) W:LEN>62 !,?3 S:LEN>62 LEN=0 W STR," "
Q
;
FULL ;
I ($Y+5)>IOSL&('$G(PSSOUT)) D TITLE
Q
;
TITLE ;
I $E($G(PSSDV))="C",$G(PSSPGCT)'=1 W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1 Q
;
W @IOF
W !,?16,TITLE,!
S Y=DT X ^DD("DD") W !,"Date printed: ",Y,?70,"Page: ",PSSPGCT,!
F MJT=1:1:79 W "="
W !
S PSSPGCT=PSSPGCT+1
Q
END ;
I '$G(PSSOUT),$E($G(PSSDV))="C" W !!,"End of Rx Consult file Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $E($G(PSSDV))="C" W !
E W @IOF
G PRTNEW
END2 ;
I '$G(PSSOUT),$E($G(PSSDV))="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $E($G(PSSDV))="C" W !
E W @IOF
DONE ;
K SEQ,MJT,PSSPGCT,PSSPGLN,Y,DIR,INDT,PSSXX,X,OITM,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
K PSSDV,PSSOUT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
PRTNEW ;
U IO
S PSSOUT=0,PSSDV=$S($E(IOST)="C":"C",1:"P")
S PSSPGCT=0,PSSPGLN=IOSL-7,PSSPGCT=1
S TITLE="WARNING LABEL-ENGLISH file - WARNING LABEL TEXT"
D TITLE
; REPORT FROM NEW WARNING LABEL SOURCE
S SEQ=0 F S SEQ=$O(^PS(50.625,SEQ)) Q:'SEQ D RPTNEW
G END2
RPTNEW ;
I $G(^PS(50.625,SEQ,0))'="" D FDBWARN D FULL I $G(PSSOUT) Q
D FULL I $G(PSSOUT) Q
W ! F MJT=1:1:70 W "-"
Q
FDBWARN D FULL Q:$G(PSSOUT) W !,"WARNING LABEL-ENGLISH NUMBER: ",+SEQ
N PSSTXT
D FULL I $G(PSSOUT) Q
W !
S PSSTXT=0 F S PSSTXT=$O(^PS(50.625,SEQ,1,PSSTXT)) Q:'PSSTXT D FULL Q:$G(PSSOUT) W !,?3,^PS(50.625,SEQ,1,PSSTXT,0)
I $G(SPANISH) W !!,"Spanish translation:" D
.S PSSTXT=0 F S PSSTXT=$O(^PS(50.626,SEQ,1,PSSTXT)) Q:'PSSTXT D FULL Q:$G(PSSOUT) W !,?3,^PS(50.626,SEQ,1,PSSTXT,0)
Q
;
KILL ;
K ^TMP("PSSWRNB",$J),NDF,PSSWRN,SEL,SPANISH,WARN54,RXNUM,WARN,WARN20,STR,PSOWARN,JJJ,TEXT,WWW,DRUGN,DRUG,DEA,TITLE
Q
DRUG ;
S NDF=0
N PSOPROD,GCNSEQNO,I,NEWWARN
S PSSWRN=""
S PSOPROD=$P($G(^PSDRUG(DR,"ND")),"^",3) I PSOPROD="" Q
S NDF=1
S GCNSEQNO=$$GET1^DIQ(50.68,PSOPROD,11,"I")
I GCNSEQNO="" Q
D GCN^PSSWRNA
Q
WARN ; ENTRY POINT DRUG ENTER/EDIT OPTION
S DRUGENT=1
S DRUG=$P($G(^PSDRUG(DA,0)),"^") I DRUG="" Q
S ^TMP("PSSWRNB",$J,DRUG)=""
D EDIT^PSSWRNE
Q
ACTIVE ;
S ACTIVE=1
I $P($G(^PSDRUG(DR,"I")),"^"),$P($G(^("I")),"^")<DT S ACTIVE=0 Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSWRNB 6261 printed Oct 16, 2024@18:35:32 Page 2
PSSWRNB ;BIR/EJW-NEW WARNING SOURCE CUSTOM WARNING LIST BUILDER ; 9/8/05 3:46pm
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**87,98,144**;9/30/97;Build 13
+2 ;
+3 ;IA: 3735 ^PSNDF(50.68
+4 ;IA: 4445 ^PS(50.625
+5 ;IA: 4446 ^PS(50.626
+6 ;IA: 4448 ^PS(50.627
+7 DO NOTE^PSSWRNE
DO NOTE2^PSSWRNE
+8 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")=" Would you like to print a list of the entries in these files"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))
WRITE !!?3,"Nothing queued to print."
GOTO SEL
+9 IF 'Y
GOTO SEL
+10 SET SPANISH=0
+11 WRITE !
KILL DIR
SET DIR(0)="Y"
SET DIR("B")="N"
SET DIR("A")=" Would you like to include the Spanish translations"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))
WRITE !!?3,"Nothing queued to print."
GOTO SEL
+12 IF Y
SET SPANISH=1
+13 DO RPT
SEL ;
+1 WRITE @IOF
+2 DO NOTE^PSSWRNE
+3 WRITE !!,?2,"Select one of the following to display drugs that match that criteria to"
+4 WRITE !,?2,"examine or edit their drug warnings:"
+5 KILL DIR
+6 SET DIR("B")=""
+7 SET DIR("A")="Enter selection or '^' to exit: "
+8 SET DIR("A",1)="1. Drug has WARNING LABEL filled in but there are no FDB warnings for the drug"
+9 SET DIR("A",2)="2. Drug has WARNING LABEL numbers higher than 20"
+10 SET DIR("A",3)="3. Select by range of drug names"
+11 SET DIR("A",4)="4. Drug has more than 5 warning labels"
+12 SET DIR("A",5)="5. Drugs containing specific WARNING LABEL number"
+13 SET DIR("A",6)="6. Drug has WARNING LABEL that does not map to new data source"
+14 SET DIR("A",7)="7. Drugs containing specific new data source warning number"
+15 SET DIR("A",8)="8. Drugs containing gender-specific warnings"
+16 SET DIR("A",9)="9. Drugs with warning mapping, but drug doesn't contain ""mapped to"" number"
+17 SET DIR(0)="SA^1:DRUGS WITH NO FDB WARNINGS;2:LOCAL WARNING (>20);3:RANGE OF DRUG NAMES;4:GREATER THAN 5 WARNINGS;5:SPECIFIC WARNING LABEL NUMBER;6:NO MAPPING;7:SPECIFIC NEW WARNING;8:GENDER-SPECIFIC WARNING;9:NO MAPPED TO"
+18 DO ^DIR
KILL DIR
SET SEL=Y
+19 IF 'SEL
GOTO KILL
+20 NEW DR,ACTIVE,SKIP,QUIT,PSO9
+21 SET SKIP=1
SET QUIT=0
+22 KILL ^TMP("PSSWRNB",$JOB)
ASK KILL DIR
WRITE !
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Exclude drugs with NEW WARNING LABEL LIST filled in"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))
GOTO SEL
+1 IF 'Y
SET SKIP=0
+2 WRITE !!,$CHAR(7),"NOTE: Only the first 5 warnings will print on the yellow auxillary labels."
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Do you want to see the warning text for all warnings"
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))
GOTO SEL
+4 SET ENDWARN=5
+5 IF Y
SET ENDWARN=99
Begin DoDot:1
+6 WRITE !," Warnings (>5) that won't print and won't be sent to CMOP"
+7 WRITE !," will be marked with a ""*"" on the following screens."
End DoDot:1
+8 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+9 ;
+10 IF SEL=1
DO SEL1^PSSWRNC
+11 ;
+12 IF SEL=2
DO SEL2^PSSWRNC
+13 ;
+14 IF SEL=3
DO SEL3^PSSWRNC
+15 ;
+16 IF SEL=4
DO SEL4^PSSWRNC
+17 ;
+18 IF SEL=5!(SEL=9)
DO SEL59^PSSWRNC
+19 ;
+20 IF SEL=6
DO SEL6^PSSWRNC
+21 ;
+22 IF SEL=7
DO SEL7^PSSWRNC
+23 ;
+24 IF SEL=8
DO SEL8^PSSWRNC
+25 ;
+26 IF 'QUIT
IF '$DATA(^TMP("PSSWRNB",$JOB))
WRITE !,"Nothing meets selection criteria"
HANG 2
SET QUIT=1
+27 IF 'QUIT
DO EDIT^PSSWRNE
+28 GOTO SEL
RPT ;
RPTQ WRITE !!,"You may queue the report to print, if you wish.",!
+1 ;
DVC KILL %ZIS,POP,IOP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !,"Nothing queued to print.",!
GOTO DONE
+1 SET ZTSAVE("*")=""
+2 IF $DATA(IO("Q"))
SET ZTRTN="PRT54^PSSWRNB"
SET ZTDESC="WARNING LABEL TEXT REPORTS"
DO ^%ZTLOAD
KILL %ZIS
WRITE !,"Report queued to print.",!
GOTO DONE
PRT54 ;
+1 USE IO
+2 SET PSSOUT=0
SET PSSDV=$SELECT($EXTRACT(IOST,1,2)="C-":"C",1:"P")
+3 SET PSSPGCT=0
SET PSSPGLN=IOSL-7
SET PSSPGCT=1
+4 SET TITLE="RX CONSULT file - WARNING LABEL TEXT"
+5 DO TITLE
+6 ;
+7 SET SEQ=0
FOR
SET SEQ=$ORDER(^PS(54,SEQ))
if 'SEQ
QUIT
DO PRTRPT
+8 GOTO END
PRTRPT ;
+1 IF $GET(^PS(54,SEQ,0))'=""
DO RXCON
DO FULL
IF $GET(PSSOUT)
QUIT
+2 DO FULL
IF $GET(PSSOUT)
QUIT
+3 WRITE !
FOR MJT=1:1:70
WRITE "-"
+4 QUIT
RXCON DO FULL
if $GET(PSSOUT)
QUIT
WRITE !,"RX CONSULT NUMBER: ",SEQ
+1 NEW PSSTXT
+2 DO FULL
IF $GET(PSSOUT)
QUIT
+3 WRITE !
+4 SET PSSTXT=0
FOR
SET PSSTXT=$ORDER(^PS(54,SEQ,1,PSSTXT))
if 'PSSTXT
QUIT
DO FULL
if $GET(PSSOUT)
QUIT
WRITE !,?3,^PS(54,SEQ,1,PSSTXT,0)
+5 IF $GET(SPANISH)
IF $DATA(^PS(54,SEQ,3))
WRITE !!,"Spanish translation:"
Begin DoDot:1
+6 SET PSSTXT=^PS(54,SEQ,3)
if PSSTXT=""
QUIT
DO FULL
if $GET(PSSOUT)
QUIT
WRITE !,?3
Begin DoDot:2
+7 NEW LEN,I,STR
+8 SET LEN=0
+9 FOR I=1:1:$LENGTH(PSSTXT," ")
SET STR=$PIECE(PSSTXT," ",I)
SET LEN=LEN+$LENGTH(STR)
if LEN>62
WRITE !,?3
if LEN>62
SET LEN=0
WRITE STR," "
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
FULL ;
+1 IF ($Y+5)>IOSL&('$GET(PSSOUT))
DO TITLE
+2 QUIT
+3 ;
TITLE ;
+1 IF $EXTRACT($GET(PSSDV))="C"
IF $GET(PSSPGCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+2 ;
+3 WRITE @IOF
+4 WRITE !,?16,TITLE,!
+5 SET Y=DT
XECUTE ^DD("DD")
WRITE !,"Date printed: ",Y,?70,"Page: ",PSSPGCT,!
+6 FOR MJT=1:1:79
WRITE "="
+7 WRITE !
+8 SET PSSPGCT=PSSPGCT+1
+9 QUIT
END ;
+1 IF '$GET(PSSOUT)
IF $EXTRACT($GET(PSSDV))="C"
WRITE !!,"End of Rx Consult file Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 IF $EXTRACT($GET(PSSDV))="C"
WRITE !
+3 IF '$TEST
WRITE @IOF
+4 GOTO PRTNEW
END2 ;
+1 IF '$GET(PSSOUT)
IF $EXTRACT($GET(PSSDV))="C"
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 IF $EXTRACT($GET(PSSDV))="C"
WRITE !
+3 IF '$TEST
WRITE @IOF
DONE ;
+1 KILL SEQ,MJT,PSSPGCT,PSSPGLN,Y,DIR,INDT,PSSXX,X,OITM,IOP,POP,IO("Q"),DIRUT,DUOUT,DTOUT
+2 KILL PSSDV,PSSOUT
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
+4 ;
PRTNEW ;
+1 USE IO
+2 SET PSSOUT=0
SET PSSDV=$SELECT($EXTRACT(IOST)="C":"C",1:"P")
+3 SET PSSPGCT=0
SET PSSPGLN=IOSL-7
SET PSSPGCT=1
+4 SET TITLE="WARNING LABEL-ENGLISH file - WARNING LABEL TEXT"
+5 DO TITLE
+6 ; REPORT FROM NEW WARNING LABEL SOURCE
+7 SET SEQ=0
FOR
SET SEQ=$ORDER(^PS(50.625,SEQ))
if 'SEQ
QUIT
DO RPTNEW
+8 GOTO END2
RPTNEW ;
+1 IF $GET(^PS(50.625,SEQ,0))'=""
DO FDBWARN
DO FULL
IF $GET(PSSOUT)
QUIT
+2 DO FULL
IF $GET(PSSOUT)
QUIT
+3 WRITE !
FOR MJT=1:1:70
WRITE "-"
+4 QUIT
FDBWARN DO FULL
if $GET(PSSOUT)
QUIT
WRITE !,"WARNING LABEL-ENGLISH NUMBER: ",+SEQ
+1 NEW PSSTXT
+2 DO FULL
IF $GET(PSSOUT)
QUIT
+3 WRITE !
+4 SET PSSTXT=0
FOR
SET PSSTXT=$ORDER(^PS(50.625,SEQ,1,PSSTXT))
if 'PSSTXT
QUIT
DO FULL
if $GET(PSSOUT)
QUIT
WRITE !,?3,^PS(50.625,SEQ,1,PSSTXT,0)
+5 IF $GET(SPANISH)
WRITE !!,"Spanish translation:"
Begin DoDot:1
+6 SET PSSTXT=0
FOR
SET PSSTXT=$ORDER(^PS(50.626,SEQ,1,PSSTXT))
if 'PSSTXT
QUIT
DO FULL
if $GET(PSSOUT)
QUIT
WRITE !,?3,^PS(50.626,SEQ,1,PSSTXT,0)
End DoDot:1
+7 QUIT
+8 ;
KILL ;
+1 KILL ^TMP("PSSWRNB",$JOB),NDF,PSSWRN,SEL,SPANISH,WARN54,RXNUM,WARN,WARN20,STR,PSOWARN,JJJ,TEXT,WWW,DRUGN,DRUG,DEA,TITLE
+2 QUIT
DRUG ;
+1 SET NDF=0
+2 NEW PSOPROD,GCNSEQNO,I,NEWWARN
+3 SET PSSWRN=""
+4 SET PSOPROD=$PIECE($GET(^PSDRUG(DR,"ND")),"^",3)
IF PSOPROD=""
QUIT
+5 SET NDF=1
+6 SET GCNSEQNO=$$GET1^DIQ(50.68,PSOPROD,11,"I")
+7 IF GCNSEQNO=""
QUIT
+8 DO GCN^PSSWRNA
+9 QUIT
WARN ; ENTRY POINT DRUG ENTER/EDIT OPTION
+1 SET DRUGENT=1
+2 SET DRUG=$PIECE($GET(^PSDRUG(DA,0)),"^")
IF DRUG=""
QUIT
+3 SET ^TMP("PSSWRNB",$JOB,DRUG)=""
+4 DO EDIT^PSSWRNE
+5 QUIT
ACTIVE ;
+1 SET ACTIVE=1
+2 IF $PIECE($GET(^PSDRUG(DR,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
SET ACTIVE=0
QUIT
+3 QUIT
