PSSWRNC ;DAL/RJS-NEW WARNING SOURCE CUSTOM WARNING LIST BUILDER CONT;
;;1.0;PHARMACY DATA MANAGEMENT;**98,144**;10/12/05;Build 13
;
;IA: 3735 ^PSNDF(50.68
;IA: 4445 ^PS(50.625
;IA: 4446 ^PS(50.626
;IA: 4448 ^PS(50.627
SEL1 ;
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I '$D(^PSDRUG(DR,0)) Q
.S WARN54=$P(^PSDRUG(DR,0),"^",8) I WARN54="" Q
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.D DRUG^PSSWRNB I PSSWRN="" S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=WARN54_"^"_NDF
Q
SEL2 ;
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I '$D(^PSDRUG(DR,0)) Q
.S WARN54=$P(^PSDRUG(DR,0),"^",8) I WARN54="" Q
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.F I=1:1:$L(WARN54,",") S WARN=$P(WARN54,",",I) I WARN>20 D
..I '$D(^PS(54,WARN)) Q
..S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=WARN54
Q
SEL3 ;; >> BEGIN *144 - RJS
W ! K DIC S DIC("B")="",DIC="^PSDRUG(",DIC(0)="AEKQM",DIC("A")="Enter starting drug name: " D ^DIC K DIC I Y=-1 S QUIT=1 Q
S PSSDRG=$P(Y,"^",2),PSSDG(PSSDRG)=1
W ! K Y S DIC("B")="",DIC="^PSDRUG(",DIC(0)="AEKQM",DIC("A")="Enter ending drug name: " D ^DIC K DIC I Y=-1 S QUIT=1 Q
S PSSEDRG=$P(Y,"^",2),PSSDG(PSSEDRG)=2 K Y
S PSS1="",PSS1=$O(PSSDG(PSS1)) I $G(PSSDG(PSS1))>1 D G SEL3 ;;<<END *144 - RJS
.W !!,?10,"The Ending drug name must come alphabetically",!,?16,"after your Starting drug name.",! H 2
.K PSSDG
W !!,"WARNINGS FOR DRUGS FROM "_PSSDRG_" TO "_PSSEDRG
W ! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1,QUIT=1 Q
I $D(^PSDRUG("B",PSSDRG)) S I=$L(PSSDRG),PSSDRG=$E(PSSDRG,1,I-1)
F S PSSDRG=$O(^PSDRUG("B",PSSDRG)) Q:PSSDRG="" Q:PSSDRG]PSSEDRG D
.S DR=$O(^PSDRUG("B",PSSDRG,0)) I DR="" Q
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.S ^TMP("PSSWRNB",$J,PSSDRG)=""
K PSSDG,PSSDRG,PSSEDRG,PSS1 ;; CLEANUP << *144 - RJS
Q
SEL4 ;
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.D DRUG^PSSWRNB I PSSWRN="" Q
.N XX S XX=DR D CHECK20^PSSWRNA
.I $L(PSSWRN,",")>5 S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=PSSWRN
Q
SEL59 ;
S DIC=54,DIC(0)="AEQM",DIC("A")="Select drugs containing RX Consult number:" D ^DIC K DIC I Y<0 Q
S RXNUM=$P(Y,"^")
I '$D(^PS(54,RXNUM)) W !,RXNUM_" is not in the RX Consult file.",! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1 Q
I SEL=9,'$G(^PS(54,RXNUM,2)) W !,RXNUM," is not mapped to a new data source warning",! K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1 Q
I SEL=9 S PSO9=$G(^PS(54,RXNUM,2))_"N" W " ",RXNUM," is mapped to ",PSO9 H 1
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I '$D(^PSDRUG(DR,0)) Q
.S WARN54=$P(^PSDRUG(DR,0),"^",8) I WARN54="" Q
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.I ","_WARN54_","[(","_RXNUM_",") D
..I SEL=9 D DRUG^PSSWRNB I PSSWRN="" Q
..I SEL=9,","_PSSWRN_","[(","_PSO9_",") Q
..S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=WARN54
Q
SEL6 ;
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I '$D(^PSDRUG(DR,0)) Q
.S WARN54=$P(^PSDRUG(DR,0),"^",8) I WARN54="" Q
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.F I=1:1:$L(WARN54,",") S WARN=$P(WARN54,",",I) I WARN,$D(^PS(54,WARN,1)),$G(^PS(54,WARN,2))="" D
..S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=WARN54
Q
SEL7 ;
W !! K DIR S DIR("A")="Select drugs containing New warning number"
S DIR("?",1)="Answer with WARNING LABEL-ENGLISH NUMBER using the format #N." ;;<<BEGIN *144 - RJS
S DIR("?",2)="Where # is the numeric number of the warning label desired."
S DIR("?")="Example: for the warning label number 15 entry 15N." ;; << END *144 - RJS
S DIR("??")="^D HELP^PSSWRNC"
S DIR(0)="FO"
D ^DIR S RXNUM=Y
I Y="N"!(Y="n")!(Y="Y")!(Y="y") W !,$C(7),?5,RXNUM_" is not a valid entry" H 2 S QUIT=1 Q
I RXNUM["N"!(RXNUM["n") S RXNUM=$TR(RXNUM,"Nn","")
I RXNUM="^"!(RXNUM="")!(RXNUM=" ") S QUIT=1 Q
I '$D(^PS(50.625,RXNUM)) W !,$C(7),?5,RXNUM_" is not in the New warning file" H 2 S QUIT=1 Q
W @IOF
W "Searching for drugs that contain new warning number "_RXNUM
S PSOWARN=RXNUM_"N",STAR="" D NEWWARN^PSSWRNE
K DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSSOUT=1 Q
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.D DRUG^PSSWRNB I PSSWRN="" Q
.I ","_PSSWRN_","[(","_RXNUM_"N,") S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=PSSWRN
Q
SEL8 ;
N WARN,GEND
S WARN=0 F S WARN=$O(^PS(50.625,WARN)) Q:'WARN I $G(^PS(50.625,WARN,2))'="" S GEND(WARN_"N")=""
I $O(GEND(""))="" Q
S DR=0 F S DR=$O(^PSDRUG(DR)) Q:'DR D
.I SKIP,$P($G(^PSDRUG(DR,"WARN")),"^")'="" Q
.D ACTIVE^PSSWRNB I 'ACTIVE Q
.D DRUG^PSSWRNB I PSSWRN="" Q
.S WARN=0 F S WARN=$O(GEND(WARN)) Q:'WARN I ","_PSSWRN_","[(","_WARN_",") D
..S ^TMP("PSSWRNB",$J,$P(^PSDRUG(DR,0),"^"))=PSSWRN
Q
HELP ; WARNING LABEL-ENGLISH NUMBER DISPLAY LOGIC *144 - RJS
N DIR,DIRUT,DUOUT,PSSCNTR,PSSIEN,PSSEND,X,Y
W #,!,"Select drugs containing New warning number:",!!,?4,"Choose from:",!
S (PSSCNTR,PSSIEN,PSSEND)=0,DIR(0)="FO",DIR("A")=" '^' to STOP"
F S PSSIEN=$O(^PS(50.625,PSSIEN)) Q:'PSSIEN!(PSSEND="^") D
.S PSSCNT=$P(^PS(50.625,PSSIEN,1,0),"^",4)
.I PSSCNTR+PSSCNT>17 D EOP Q:PSSEND="^"
.W !,?4,PSSIEN,"N"
.F PSSCT=1:1:PSSCNT W:PSSCT>1 ! W ?12,$G(^PS(50.625,PSSIEN,1,PSSCT,0))
.S PSSCNTR=PSSCNTR+PSSCNT
K PSSCNT,PSSCT
Q
EOP ; END OF PAGE LOGIC *144 - RJS
D ^DIR
I $G(X)!(Y="^") S PSSEND="^" Q
W #,!,"Select drugs containing New warning number:",!!,?4,"Choose from:",!
S PSSCNTR=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSWRNC 5664 printed Oct 16, 2024@18:35:33 Page 2
PSSWRNC ;DAL/RJS-NEW WARNING SOURCE CUSTOM WARNING LIST BUILDER CONT;
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**98,144**;10/12/05;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
SEL1 ;
+1 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+2 IF '$DATA(^PSDRUG(DR,0))
QUIT
+3 SET WARN54=$PIECE(^PSDRUG(DR,0),"^",8)
IF WARN54=""
QUIT
+4 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+5 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+6 DO DRUG^PSSWRNB
IF PSSWRN=""
SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=WARN54_"^"_NDF
End DoDot:1
+7 QUIT
SEL2 ;
+1 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+2 IF '$DATA(^PSDRUG(DR,0))
QUIT
+3 SET WARN54=$PIECE(^PSDRUG(DR,0),"^",8)
IF WARN54=""
QUIT
+4 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+5 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+6 FOR I=1:1:$LENGTH(WARN54,",")
SET WARN=$PIECE(WARN54,",",I)
IF WARN>20
Begin DoDot:2
+7 IF '$DATA(^PS(54,WARN))
QUIT
+8 SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=WARN54
End DoDot:2
End DoDot:1
+9 QUIT
SEL3 ;; >> BEGIN *144 - RJS
+1 WRITE !
KILL DIC
SET DIC("B")=""
SET DIC="^PSDRUG("
SET DIC(0)="AEKQM"
SET DIC("A")="Enter starting drug name: "
DO ^DIC
KILL DIC
IF Y=-1
SET QUIT=1
QUIT
+2 SET PSSDRG=$PIECE(Y,"^",2)
SET PSSDG(PSSDRG)=1
+3 WRITE !
KILL Y
SET DIC("B")=""
SET DIC="^PSDRUG("
SET DIC(0)="AEKQM"
SET DIC("A")="Enter ending drug name: "
DO ^DIC
KILL DIC
IF Y=-1
SET QUIT=1
QUIT
+4 SET PSSEDRG=$PIECE(Y,"^",2)
SET PSSDG(PSSEDRG)=2
KILL Y
+5 ;;<<END *144 - RJS
SET PSS1=""
SET PSS1=$ORDER(PSSDG(PSS1))
IF $GET(PSSDG(PSS1))>1
Begin DoDot:1
+6 WRITE !!,?10,"The Ending drug name must come alphabetically",!,?16,"after your Starting drug name.",!
HANG 2
+7 KILL PSSDG
End DoDot:1
GOTO SEL3
+8 WRITE !!,"WARNINGS FOR DRUGS FROM "_PSSDRG_" TO "_PSSEDRG
+9 WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
SET QUIT=1
QUIT
+10 IF $DATA(^PSDRUG("B",PSSDRG))
SET I=$LENGTH(PSSDRG)
SET PSSDRG=$EXTRACT(PSSDRG,1,I-1)
+11 FOR
SET PSSDRG=$ORDER(^PSDRUG("B",PSSDRG))
if PSSDRG=""
QUIT
if PSSDRG]PSSEDRG
QUIT
Begin DoDot:1
+12 SET DR=$ORDER(^PSDRUG("B",PSSDRG,0))
IF DR=""
QUIT
+13 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+14 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+15 SET ^TMP("PSSWRNB",$JOB,PSSDRG)=""
End DoDot:1
+16 ;; CLEANUP << *144 - RJS
KILL PSSDG,PSSDRG,PSSEDRG,PSS1
+17 QUIT
SEL4 ;
+1 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+2 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+3 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+4 DO DRUG^PSSWRNB
IF PSSWRN=""
QUIT
+5 NEW XX
SET XX=DR
DO CHECK20^PSSWRNA
+6 IF $LENGTH(PSSWRN,",")>5
SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=PSSWRN
End DoDot:1
+7 QUIT
SEL59 ;
+1 SET DIC=54
SET DIC(0)="AEQM"
SET DIC("A")="Select drugs containing RX Consult number:"
DO ^DIC
KILL DIC
IF Y<0
QUIT
+2 SET RXNUM=$PIECE(Y,"^")
+3 IF '$DATA(^PS(54,RXNUM))
WRITE !,RXNUM_" is not in the RX Consult file.",!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+4 IF SEL=9
IF '$GET(^PS(54,RXNUM,2))
WRITE !,RXNUM," is not mapped to a new data source warning",!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+5 IF SEL=9
SET PSO9=$GET(^PS(54,RXNUM,2))_"N"
WRITE " ",RXNUM," is mapped to ",PSO9
HANG 1
+6 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+7 IF '$DATA(^PSDRUG(DR,0))
QUIT
+8 SET WARN54=$PIECE(^PSDRUG(DR,0),"^",8)
IF WARN54=""
QUIT
+9 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+10 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+11 IF ","_WARN54_","[(","_RXNUM_",")
Begin DoDot:2
+12 IF SEL=9
DO DRUG^PSSWRNB
IF PSSWRN=""
QUIT
+13 IF SEL=9
IF ","_PSSWRN_","[(","_PSO9_",")
QUIT
+14 SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=WARN54
End DoDot:2
End DoDot:1
+15 QUIT
SEL6 ;
+1 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+2 IF '$DATA(^PSDRUG(DR,0))
QUIT
+3 SET WARN54=$PIECE(^PSDRUG(DR,0),"^",8)
IF WARN54=""
QUIT
+4 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+5 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+6 FOR I=1:1:$LENGTH(WARN54,",")
SET WARN=$PIECE(WARN54,",",I)
IF WARN
IF $DATA(^PS(54,WARN,1))
IF $GET(^PS(54,WARN,2))=""
Begin DoDot:2
+7 SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=WARN54
End DoDot:2
End DoDot:1
+8 QUIT
SEL7 ;
+1 WRITE !!
KILL DIR
SET DIR("A")="Select drugs containing New warning number"
+2 ;;<<BEGIN *144 - RJS
SET DIR("?",1)="Answer with WARNING LABEL-ENGLISH NUMBER using the format #N."
+3 SET DIR("?",2)="Where # is the numeric number of the warning label desired."
+4 ;; << END *144 - RJS
SET DIR("?")="Example: for the warning label number 15 entry 15N."
+5 SET DIR("??")="^D HELP^PSSWRNC"
+6 SET DIR(0)="FO"
+7 DO ^DIR
SET RXNUM=Y
+8 IF Y="N"!(Y="n")!(Y="Y")!(Y="y")
WRITE !,$CHAR(7),?5,RXNUM_" is not a valid entry"
HANG 2
SET QUIT=1
QUIT
+9 IF RXNUM["N"!(RXNUM["n")
SET RXNUM=$TRANSLATE(RXNUM,"Nn","")
+10 IF RXNUM="^"!(RXNUM="")!(RXNUM=" ")
SET QUIT=1
QUIT
+11 IF '$DATA(^PS(50.625,RXNUM))
WRITE !,$CHAR(7),?5,RXNUM_" is not in the New warning file"
HANG 2
SET QUIT=1
QUIT
+12 WRITE @IOF
+13 WRITE "Searching for drugs that contain new warning number "_RXNUM
+14 SET PSOWARN=RXNUM_"N"
SET STAR=""
DO NEWWARN^PSSWRNE
+15 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+16 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+17 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+18 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+19 DO DRUG^PSSWRNB
IF PSSWRN=""
QUIT
+20 IF ","_PSSWRN_","[(","_RXNUM_"N,")
SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=PSSWRN
End DoDot:1
+21 QUIT
SEL8 ;
+1 NEW WARN,GEND
+2 SET WARN=0
FOR
SET WARN=$ORDER(^PS(50.625,WARN))
if 'WARN
QUIT
IF $GET(^PS(50.625,WARN,2))'=""
SET GEND(WARN_"N")=""
+3 IF $ORDER(GEND(""))=""
QUIT
+4 SET DR=0
FOR
SET DR=$ORDER(^PSDRUG(DR))
if 'DR
QUIT
Begin DoDot:1
+5 IF SKIP
IF $PIECE($GET(^PSDRUG(DR,"WARN")),"^")'=""
QUIT
+6 DO ACTIVE^PSSWRNB
IF 'ACTIVE
QUIT
+7 DO DRUG^PSSWRNB
IF PSSWRN=""
QUIT
+8 SET WARN=0
FOR
SET WARN=$ORDER(GEND(WARN))
if 'WARN
QUIT
IF ","_PSSWRN_","[(","_WARN_",")
Begin DoDot:2
+9 SET ^TMP("PSSWRNB",$JOB,$PIECE(^PSDRUG(DR,0),"^"))=PSSWRN
End DoDot:2
End DoDot:1
+10 QUIT
HELP ; WARNING LABEL-ENGLISH NUMBER DISPLAY LOGIC *144 - RJS
+1 NEW DIR,DIRUT,DUOUT,PSSCNTR,PSSIEN,PSSEND,X,Y
+2 WRITE #,!,"Select drugs containing New warning number:",!!,?4,"Choose from:",!
+3 SET (PSSCNTR,PSSIEN,PSSEND)=0
SET DIR(0)="FO"
SET DIR("A")=" '^' to STOP"
+4 FOR
SET PSSIEN=$ORDER(^PS(50.625,PSSIEN))
if 'PSSIEN!(PSSEND="^")
QUIT
Begin DoDot:1
+5 SET PSSCNT=$PIECE(^PS(50.625,PSSIEN,1,0),"^",4)
+6 IF PSSCNTR+PSSCNT>17
DO EOP
if PSSEND="^"
QUIT
+7 WRITE !,?4,PSSIEN,"N"
+8 FOR PSSCT=1:1:PSSCNT
if PSSCT>1
WRITE !
WRITE ?12,$GET(^PS(50.625,PSSIEN,1,PSSCT,0))
+9 SET PSSCNTR=PSSCNTR+PSSCNT
End DoDot:1
+10 KILL PSSCNT,PSSCT
+11 QUIT
EOP ; END OF PAGE LOGIC *144 - RJS
+1 DO ^DIR
+2 IF $GET(X)!(Y="^")
SET PSSEND="^"
QUIT
+3 WRITE #,!,"Select drugs containing New warning number:",!!,?4,"Choose from:",!
+4 SET PSSCNTR=0
+5 QUIT
