PSSPKIPR ;BIR/MHA-DEA/PKI Post-Inst DEA-CS FED SCH mismatch report ;08/08/02
;;1.0;PHARMACY DATA MANAGEMENT;**61,76**;9/30/97
;Reference to ^PSNDF(50.68 supported by DBIA 3735
Q:'$D(OP)
DEV ;
K %ZIS,IO("Q"),POP,ZTSK S PSDIO=ION,%ZIS="QM" D ^%ZIS
S ZZ="PSSPKI"
I POP W !,"NO DEVICE SELECTED !!!" G END
I $D(IO("Q")) K IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK D G END
.S ZTRTN="EN^PSSPKIPR",ZTDESC="PKI CS vs DEA-Spec-Hdlg inconsistent-discrepancy report"
.N I F I="OP","ZZ" S ZTSAVE(I)=""
.D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
W:$E(IOST)["C" !!,"......Compiling report, this may take a few minutes......",!,"......It is better to QUEUE this report!!........"
EN ;
K ^XTMP(ZZ) N PSSX,PSSD,PSSJ,PSSK,PSSN,NDR
S PSSX="" F S PSSX=$O(^PSDRUG("B",PSSX)) Q:PSSX="" D
.S PSSN=0 F S PSSN=$O(^PSDRUG("B",PSSX,PSSN)) Q:'PSSN D
..Q:'$D(^PSDRUG(PSSN,0))
..I $P($G(^PSDRUG(PSSN,"I")),"^"),$P($G(^("I")),"^")<DT Q
..S PSSD=$P($G(^PSDRUG(PSSN,0)),"^",3) Q:PSSD=""
..I PSSD[1!(PSSD[2)!(PSSD[3)!(PSSD[4)!(PSSD[5)!($P($G(^PSDRUG(PSSN,2)),"^",3)["N") S PSSJ=0,NDR="" D D:PSSJ REP
...I PSSD["A"&(PSSD["C"),+PSSD=2!(+PSSD=3) S PSSJ=3 Q
...S PSSL="",PSSK=$P($G(^PSDRUG(PSSN,"ND")),"^",3) I 'PSSK S PSSJ=2 Q
...S PSSL=$$GET1^DIQ(50.68,PSSK,19,"I") Q:'PSSL
...S PSSL=$E(PSSL)_$S(PSSL["n":"C",+PSSL=2!(+PSSL=3):"A",1:"")
...I $L(PSSL)=1,PSSD[PSSL Q
...I PSSD[$E(PSSL),PSSD[$E(PSSL,2) Q
...S PSSJ=1,NDR=$$GET1^DIQ(50.68,PSSK,.01),PSSL=$$GET1^DIQ(50.68,PSSK,19,"I")
I OP=4!(OP="A") D REP4
D EN1 Q
;
REP S ^XTMP(ZZ,PSSJ,PSSX)=NDR_"^"_$P($G(^PSDRUG(PSSN,0)),"^",2)_"^"_PSSD_$S(PSSJ=1:"^"_PSSL,1:"")
Q
EN1 ;
K ^TMP($J) N S1,S2 S $E(S1,42)="",$E(S2,12)=""
F J=1,2,3,4 I $D(^XTMP(ZZ,J)) D
.S K="",XX=1 F S K=$O(^XTMP(ZZ,J,K)) Q:K="" D
..S:J'=4 QQ=^XTMP(ZZ,J,K)
..I J=1 D PDET Q
..I J=4 D REPN Q
..S ^TMP($J,J,XX)=$E(K_S1,1,42)_$E($P(QQ,"^",2)_S2,1,10)_$E($P(QQ,"^",3)_S2,1,10),XX=XX+1
TST U IO S PG=1,QU=0,$P(UL,"=",80)="" S:OP="A" T=1 S:$G(OP) T=OP D HD
I OP="A" I '$D(^TMP($J)) W !!,"********** NO DATA TO PRINT **********",!! Q
I $G(OP) D G END
.I '$D(^TMP($J,OP)) W !!,"********** NO DATA TO PRINT **********",!! Q
.D PR
I OP="A" D G END
.F T=1,2,3,4 D Q:QU
..I T'=1 S PG=1 D HD
..D PR Q:QU
PR S K="" F S K=$O(^TMP($J,T,K)) Q:'K W !,^TMP($J,T,K) D:($Y+4)>IOSL HD Q:QU
Q
END K ^XTMP(ZZ),^TMP($J)
W ! W:$E(IOST)'["C" @IOF D ^%ZISC
K ZZ,AR,DIR,DIRUT,DOS,I,J,K,T,NDR,OP,PG,PSSD,PSSJ,PSSK,PSSL,PSSN,PSSX,QQ,QU,S1,S2,T,UL,XX,ZTSAVE
S:$D(ZTQUEUED) ZTREQ="@"
Q
PDET ;
S ^TMP($J,J,XX)="GENERIC NAME: "_K,XX=XX+1
S ^TMP($J,J,XX)="VA PRODUCT NAME: "_$P(QQ,"^"),XX=XX+1
S ^TMP($J,J,XX)="VA CLASS: "_$P(QQ,"^",2),XX=XX+1
S ^TMP($J,J,XX)="CURRENT DEA, SPECIAL HDLG: "_$P(QQ,"^",3),XX=XX+1
S ^TMP($J,J,XX)="CS FEDERAL SCHEDULE: "_$P(QQ,"^",4),XX=XX+1
S ^TMP($J,J,XX)="",XX=XX+1
Q
REP4 ;
N OI S PSSL="" F S PSSL=$O(^PSDRUG("ASP",PSSL)) Q:'PSSL D
.Q:'$D(^PS(50.7,PSSL,0)) S OI=$P(^PS(50.7,PSSL,0),"^")
.S PSSN="" K AR S (I,J)=0 F S PSSN=$O(^PSDRUG("ASP",PSSL,PSSN)) Q:'PSSN D
..Q:'$D(^PSDRUG(PSSN,0))
..I $P($G(^PSDRUG(PSSN,"I")),"^"),$P($G(^("I")),"^")<DT Q
..S PSSD=$P($G(^PSDRUG(PSSN,0)),"^",3)
..Q:PSSD=""
..I PSSD["A"!(PSSD["C") I PSSD[1!(PSSD[2)!(PSSD[3)!(PSSD[4)!(PSSD[5)!($P($G(^PSDRUG(PSSN,2)),"^",3)["N") D
...S PSSK=$P($G(^PSDRUG(PSSN,"ND")),"^",3)
...S:PSSK PSSK=$$GET1^DIQ(50.68,PSSK,19,"I")
...S AR(PSSN)=OI_"^"_PSSL_"^"_PSSN_"^"_$P(^PSDRUG(PSSN,0),"^")_"^"_PSSD_"^"_PSSK
...I PSSD["A" S I=1 Q
...I PSSD["C" S J=1
.I I,J S I="" F S I=$O(AR(I)) Q:'I S AR=AR(I),^XTMP(ZZ,4,$P(AR,"^",1,2),I)=$P(AR,"^",3,6)
Q
REPN ;
S DOS="" S DOS=$P(^PS(50.7,$P(K,"^",2),0),"^",2) I DOS S DOS=$P(^PS(50.606,DOS,0),"^")
S ^TMP($J,J,XX)=$P(K,"^")_" "_DOS,XX=XX+1
S I=0 F S I=$O(^XTMP(ZZ,J,K,I)) Q:'I S QQ=$G(^XTMP(ZZ,J,K,I)) D
.S ^TMP($J,J,XX)=" "_$E(I_" ",1,6)_$E($P(QQ,"^",2)_S1,1,43)_$E($P(QQ,"^",3)_" ",1,13)_$P(QQ,"^",4),XX=XX+1
S ^TMP($J,J,XX)="",XX=XX+1
Q
GRP ;
S PG=1,QU=0 S:OP="A" T=1 D HD
HD I PG>1,$E(IOST)="C" S DIR(0)="E" D ^DIR I $D(DIRUT) S QU=1 Q
W @IOF D @("H"_T) W !,UL,! S PG=PG+1
Q
H1 W !?5,"DEA Special Handling & CS Federal Schedule Discrepancies",?71,"Page: ",PG
I PG=1 D
.W !!,"The following active Controlled Substances were identified as having a"
.W !,"discrepancy between the CS FEDERAL SCHEDULE in the VA PRODUCT file (#50.68)"
.W !,"and the DEA,SPECIAL HDLG code in the DRUG file (#50). You may wish to update"
.W !,"the DEA,SPECIAL HDLG code for these drugs."
.W !!,"PLEASE NOTE: The CS FEDERAL SCHEDULE will only identify DEA, SPECIAL HDLG"
.W !,"codes of 1, 2A, 2C, 3A, 3C, 4, or 5. In addition to these codes, you may"
.W !,"also use other DEA, SPECIAL HDLG codes such as L, P,R, S, etc., as needed."
Q
H2 W !?10,"Controlled Substances Not Matched to NDF",?71,"Page: ",PG
I PG=1 D
.W !!,"The following active Controlled Substances have not been matched to NDF."
.W !,"You may wish to match these drugs."
.W !!,"GENERIC NAME",?43,"VA CLASS",?53,"CURR DEA, SPECIAL HDLG"
Q
H3 W !?7,"CS (DRUGS) with Inconsistent DEA Special Handling Field",?71,"Page: ",PG
I PG=1 D
.W !!,"The following active drugs are defined as Controlled Substances, but"
.W !,"not classified correctly as Narcotics or Non-Narcotics."
.W !,"Please make sure they are defined correctly."
.W !!,"GENERIC NAME",?43,"VA CLASS",?53,"CURR DEA, SPECIAL HDLG"
Q
H4 W !?3,"CS (ORDERABLE ITEMS) with Inconsistent DEA Special Handling Field",?71,"Page: ",PG
I PG=1 D
.W !!,"The following pharmacy orderable items are associated with active dispense"
.W !,"drugs that have a discrepancy within their DEA Special Hdlg fields. Please"
.W !,"correct all entries to identify these orderable items with a specific"
.W !,"Controlled Substance schedule."
.W !!,"PHARMACY ORDERABLE ITEM"
.W !," IEN DISPENSE DRUG",?52,"DEA SPEC. HDLG",?67,"CS FED. SCHE."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPKIPR 5991 printed Apr 09, 2024@21:33:38 Page 2
PSSPKIPR ;BIR/MHA-DEA/PKI Post-Inst DEA-CS FED SCH mismatch report ;08/08/02
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**61,76**;9/30/97
+2 ;Reference to ^PSNDF(50.68 supported by DBIA 3735
+3 if '$DATA(OP)
QUIT
DEV ;
+1 KILL %ZIS,IO("Q"),POP,ZTSK
SET PSDIO=ION
SET %ZIS="QM"
DO ^%ZIS
+2 SET ZZ="PSSPKI"
+3 IF POP
WRITE !,"NO DEVICE SELECTED !!!"
GOTO END
+4 IF $DATA(IO("Q"))
KILL IO("Q"),ZTIO,ZTSAVE,ZTDTH,ZTSK
Begin DoDot:1
+5 SET ZTRTN="EN^PSSPKIPR"
SET ZTDESC="PKI CS vs DEA-Spec-Hdlg inconsistent-discrepancy report"
+6 NEW I
FOR I="OP","ZZ"
SET ZTSAVE(I)=""
+7 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
KILL ZTSK
End DoDot:1
GOTO END
+8 if $EXTRACT(IOST)["C"
WRITE !!,"......Compiling report, this may take a few minutes......",!,"......It is better to QUEUE this report!!........"
EN ;
+1 KILL ^XTMP(ZZ)
NEW PSSX,PSSD,PSSJ,PSSK,PSSN,NDR
+2 SET PSSX=""
FOR
SET PSSX=$ORDER(^PSDRUG("B",PSSX))
if PSSX=""
QUIT
Begin DoDot:1
+3 SET PSSN=0
FOR
SET PSSN=$ORDER(^PSDRUG("B",PSSX,PSSN))
if 'PSSN
QUIT
Begin DoDot:2
+4 if '$DATA(^PSDRUG(PSSN,0))
QUIT
+5 IF $PIECE($GET(^PSDRUG(PSSN,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+6 SET PSSD=$PIECE($GET(^PSDRUG(PSSN,0)),"^",3)
if PSSD=""
QUIT
+7 IF PSSD[1!(PSSD[2)!(PSSD[3)!(PSSD[4)!(PSSD[5)!($PIECE($GET(^PSDRUG(PSSN,2)),"^",3)["N")
SET PSSJ=0
SET NDR=""
Begin DoDot:3
+8 IF PSSD["A"&(PSSD["C")
IF +PSSD=2!(+PSSD=3)
SET PSSJ=3
QUIT
+9 SET PSSL=""
SET PSSK=$PIECE($GET(^PSDRUG(PSSN,"ND")),"^",3)
IF 'PSSK
SET PSSJ=2
QUIT
+10 SET PSSL=$$GET1^DIQ(50.68,PSSK,19,"I")
if 'PSSL
QUIT
+11 SET PSSL=$EXTRACT(PSSL)_$SELECT(PSSL["n":"C",+PSSL=2!(+PSSL=3):"A",1:"")
+12 IF $LENGTH(PSSL)=1
IF PSSD[PSSL
QUIT
+13 IF PSSD[$EXTRACT(PSSL)
IF PSSD[$EXTRACT(PSSL,2)
QUIT
+14 SET PSSJ=1
SET NDR=$$GET1^DIQ(50.68,PSSK,.01)
SET PSSL=$$GET1^DIQ(50.68,PSSK,19,"I")
End DoDot:3
if PSSJ
DO REP
End DoDot:2
End DoDot:1
+15 IF OP=4!(OP="A")
DO REP4
+16 DO EN1
QUIT
+17 ;
REP SET ^XTMP(ZZ,PSSJ,PSSX)=NDR_"^"_$PIECE($GET(^PSDRUG(PSSN,0)),"^",2)_"^"_PSSD_$SELECT(PSSJ=1:"^"_PSSL,1:"")
+1 QUIT
EN1 ;
+1 KILL ^TMP($JOB)
NEW S1,S2
SET $EXTRACT(S1,42)=""
SET $EXTRACT(S2,12)=""
+2 FOR J=1,2,3,4
IF $DATA(^XTMP(ZZ,J))
Begin DoDot:1
+3 SET K=""
SET XX=1
FOR
SET K=$ORDER(^XTMP(ZZ,J,K))
if K=""
QUIT
Begin DoDot:2
+4 if J'=4
SET QQ=^XTMP(ZZ,J,K)
+5 IF J=1
DO PDET
QUIT
+6 IF J=4
DO REPN
QUIT
+7 SET ^TMP($JOB,J,XX)=$EXTRACT(K_S1,1,42)_$EXTRACT($PIECE(QQ,"^",2)_S2,1,10)_$EXTRACT($PIECE(QQ,"^",3)_S2,1,10)
SET XX=XX+1
End DoDot:2
End DoDot:1
TST USE IO
SET PG=1
SET QU=0
SET $PIECE(UL,"=",80)=""
if OP="A"
SET T=1
if $GET(OP)
SET T=OP
DO HD
+1 IF OP="A"
IF '$DATA(^TMP($JOB))
WRITE !!,"********** NO DATA TO PRINT **********",!!
QUIT
+2 IF $GET(OP)
Begin DoDot:1
+3 IF '$DATA(^TMP($JOB,OP))
WRITE !!,"********** NO DATA TO PRINT **********",!!
QUIT
+4 DO PR
End DoDot:1
GOTO END
+5 IF OP="A"
Begin DoDot:1
+6 FOR T=1,2,3,4
Begin DoDot:2
+7 IF T'=1
SET PG=1
DO HD
+8 DO PR
if QU
QUIT
End DoDot:2
if QU
QUIT
End DoDot:1
GOTO END
PR SET K=""
FOR
SET K=$ORDER(^TMP($JOB,T,K))
if 'K
QUIT
WRITE !,^TMP($JOB,T,K)
if ($Y+4)>IOSL
DO HD
if QU
QUIT
+1 QUIT
END KILL ^XTMP(ZZ),^TMP($JOB)
+1 WRITE !
if $EXTRACT(IOST)'["C"
WRITE @IOF
DO ^%ZISC
+2 KILL ZZ,AR,DIR,DIRUT,DOS,I,J,K,T,NDR,OP,PG,PSSD,PSSJ,PSSK,PSSL,PSSN,PSSX,QQ,QU,S1,S2,T,UL,XX,ZTSAVE
+3 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 QUIT
PDET ;
+1 SET ^TMP($JOB,J,XX)="GENERIC NAME: "_K
SET XX=XX+1
+2 SET ^TMP($JOB,J,XX)="VA PRODUCT NAME: "_$PIECE(QQ,"^")
SET XX=XX+1
+3 SET ^TMP($JOB,J,XX)="VA CLASS: "_$PIECE(QQ,"^",2)
SET XX=XX+1
+4 SET ^TMP($JOB,J,XX)="CURRENT DEA, SPECIAL HDLG: "_$PIECE(QQ,"^",3)
SET XX=XX+1
+5 SET ^TMP($JOB,J,XX)="CS FEDERAL SCHEDULE: "_$PIECE(QQ,"^",4)
SET XX=XX+1
+6 SET ^TMP($JOB,J,XX)=""
SET XX=XX+1
+7 QUIT
REP4 ;
+1 NEW OI
SET PSSL=""
FOR
SET PSSL=$ORDER(^PSDRUG("ASP",PSSL))
if 'PSSL
QUIT
Begin DoDot:1
+2 if '$DATA(^PS(50.7,PSSL,0))
QUIT
SET OI=$PIECE(^PS(50.7,PSSL,0),"^")
+3 SET PSSN=""
KILL AR
SET (I,J)=0
FOR
SET PSSN=$ORDER(^PSDRUG("ASP",PSSL,PSSN))
if 'PSSN
QUIT
Begin DoDot:2
+4 if '$DATA(^PSDRUG(PSSN,0))
QUIT
+5 IF $PIECE($GET(^PSDRUG(PSSN,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+6 SET PSSD=$PIECE($GET(^PSDRUG(PSSN,0)),"^",3)
+7 if PSSD=""
QUIT
+8 IF PSSD["A"!(PSSD["C")
IF PSSD[1!(PSSD[2)!(PSSD[3)!(PSSD[4)!(PSSD[5)!($PIECE($GET(^PSDRUG(PSSN,2)),"^",3)["N")
Begin DoDot:3
+9 SET PSSK=$PIECE($GET(^PSDRUG(PSSN,"ND")),"^",3)
+10 if PSSK
SET PSSK=$$GET1^DIQ(50.68,PSSK,19,"I")
+11 SET AR(PSSN)=OI_"^"_PSSL_"^"_PSSN_"^"_$PIECE(^PSDRUG(PSSN,0),"^")_"^"_PSSD_"^"_PSSK
+12 IF PSSD["A"
SET I=1
QUIT
+13 IF PSSD["C"
SET J=1
End DoDot:3
End DoDot:2
+14 IF I
IF J
SET I=""
FOR
SET I=$ORDER(AR(I))
if 'I
QUIT
SET AR=AR(I)
SET ^XTMP(ZZ,4,$PIECE(AR,"^",1,2),I)=$PIECE(AR,"^",3,6)
End DoDot:1
+15 QUIT
REPN ;
+1 SET DOS=""
SET DOS=$PIECE(^PS(50.7,$PIECE(K,"^",2),0),"^",2)
IF DOS
SET DOS=$PIECE(^PS(50.606,DOS,0),"^")
+2 SET ^TMP($JOB,J,XX)=$PIECE(K,"^")_" "_DOS
SET XX=XX+1
+3 SET I=0
FOR
SET I=$ORDER(^XTMP(ZZ,J,K,I))
if 'I
QUIT
SET QQ=$GET(^XTMP(ZZ,J,K,I))
Begin DoDot:1
+4 SET ^TMP($JOB,J,XX)=" "_$EXTRACT(I_" ",1,6)_$EXTRACT($PIECE(QQ,"^",2)_S1,1,43)_$EXTRACT($PIECE(QQ,"^",3)_" ",1,13)_$PIECE(QQ,"^",4)
SET XX=XX+1
End DoDot:1
+5 SET ^TMP($JOB,J,XX)=""
SET XX=XX+1
+6 QUIT
GRP ;
+1 SET PG=1
SET QU=0
if OP="A"
SET T=1
DO HD
HD IF PG>1
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET QU=1
QUIT
+1 WRITE @IOF
DO @("H"_T)
WRITE !,UL,!
SET PG=PG+1
+2 QUIT
H1 WRITE !?5,"DEA Special Handling & CS Federal Schedule Discrepancies",?71,"Page: ",PG
+1 IF PG=1
Begin DoDot:1
+2 WRITE !!,"The following active Controlled Substances were identified as having a"
+3 WRITE !,"discrepancy between the CS FEDERAL SCHEDULE in the VA PRODUCT file (#50.68)"
+4 WRITE !,"and the DEA,SPECIAL HDLG code in the DRUG file (#50). You may wish to update"
+5 WRITE !,"the DEA,SPECIAL HDLG code for these drugs."
+6 WRITE !!,"PLEASE NOTE: The CS FEDERAL SCHEDULE will only identify DEA, SPECIAL HDLG"
+7 WRITE !,"codes of 1, 2A, 2C, 3A, 3C, 4, or 5. In addition to these codes, you may"
+8 WRITE !,"also use other DEA, SPECIAL HDLG codes such as L, P,R, S, etc., as needed."
End DoDot:1
+9 QUIT
H2 WRITE !?10,"Controlled Substances Not Matched to NDF",?71,"Page: ",PG
+1 IF PG=1
Begin DoDot:1
+2 WRITE !!,"The following active Controlled Substances have not been matched to NDF."
+3 WRITE !,"You may wish to match these drugs."
+4 WRITE !!,"GENERIC NAME",?43,"VA CLASS",?53,"CURR DEA, SPECIAL HDLG"
End DoDot:1
+5 QUIT
H3 WRITE !?7,"CS (DRUGS) with Inconsistent DEA Special Handling Field",?71,"Page: ",PG
+1 IF PG=1
Begin DoDot:1
+2 WRITE !!,"The following active drugs are defined as Controlled Substances, but"
+3 WRITE !,"not classified correctly as Narcotics or Non-Narcotics."
+4 WRITE !,"Please make sure they are defined correctly."
+5 WRITE !!,"GENERIC NAME",?43,"VA CLASS",?53,"CURR DEA, SPECIAL HDLG"
End DoDot:1
+6 QUIT
H4 WRITE !?3,"CS (ORDERABLE ITEMS) with Inconsistent DEA Special Handling Field",?71,"Page: ",PG
+1 IF PG=1
Begin DoDot:1
+2 WRITE !!,"The following pharmacy orderable items are associated with active dispense"
+3 WRITE !,"drugs that have a discrepancy within their DEA Special Hdlg fields. Please"
+4 WRITE !,"correct all entries to identify these orderable items with a specific"
+5 WRITE !,"Controlled Substance schedule."
+6 WRITE !!,"PHARMACY ORDERABLE ITEM"
+7 WRITE !," IEN DISPENSE DRUG",?52,"DEA SPEC. HDLG",?67,"CS FED. SCHE."
End DoDot:1
+8 QUIT
