PSSPKIPI ;BIR/MHA-DEA/PKI Post-Inst DEA-CS FED SCH mismatch report ;08/08/02
;;1.0;PHARMACY DATA MANAGEMENT;**61**;9/30/97
;Reference to ^PSNDF(50.68 supported by DBIA 3735
START ;
S ZZ="PSSPKI"
K ^XTMP(ZZ,$J) 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
..;Q:$P($G(^PSDRUG(PSSN,2)),"^",3)'["O"
..S PSSD=$P($G(^PSDRUG(PSSN,0)),"^",3) I PSSD="" D GCS Q
..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")
D REP4,SM Q
;
GCS S PSSL="",PSSK=$P($G(^PSDRUG(PSSN,"ND")),"^",3) Q:'PSSK
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:"")
S:+PSSL $P(^PSDRUG(PSSN,0),"^",3)=PSSL
Q
;
REP S ^XTMP(ZZ,$J,PSSJ,PSSX)=NDR_"^"_$P($G(^PSDRUG(PSSN,0)),"^",2)_"^"_PSSD_$S(PSSJ=1:"^"_PSSL,1:"")
Q
SM K ^TMP($J),XMY
F J=1,2,3,4 I $D(^XTMP(ZZ,$J,J)) D
.N S1,S2 S $E(S1,42)="",$E(S2,12)="",K="",$P(UL,"=",79)=""
.D:J=1
..S ^TMP($J,J,1)="The following active Controlled Substances were identified as having a"
..S ^TMP($J,J,2)="discrepancy between the CS FEDERAL SCHEDULE in the VA PRODUCT file (#50.68)"
..S ^TMP($J,J,3)="and the DEA,SPECIAL HDLG code in the DRUG file (#50). You may wish to update"
..S ^TMP($J,J,4)="the DEA,SPECIAL HDLG code for these drugs."
..S ^TMP($J,J,5)=""
..S ^TMP($J,J,6)="PLEASE NOTE: The CS FEDERAL SCHEDULE will only identify DEA, SPECIAL HDLG"
..S ^TMP($J,J,8)="codes of 1, 2A, 2C, 3A, 3C, 4, or 5. In addition to these codes, you may"
..S ^TMP($J,J,9)="also use other DEA, SPECIAL HDLG codes such as L, P,R, S, etc., as needed."
..S ^TMP($J,J,10)="",XX=11
.D:J=2
..S ^TMP($J,J,1)="The following active Controlled Substances have not been matched to NDF."
..S ^TMP($J,J,2)="You may wish to match these drugs."
..S ^TMP($J,J,5)=""
..S ^TMP($J,J,6)="GENERIC NAME",$E(^TMP($J,J,6),43)="VA CLASS",$E(^TMP($J,J,6),53)="CURR DEA, SPECIAL HDLG"
..S ^TMP($J,J,7)=UL,^TMP($J,J,8)="",XX=9
.D:J=3
..S ^TMP($J,J,1)="The following active drugs are defined as Controlled Substances, but"
..S ^TMP($J,J,2)="not classified correctly as Narcotics or Non-Narcotics."
..S ^TMP($J,J,3)="Please make sure they are defined correctly."
..S ^TMP($J,J,5)=""
..S ^TMP($J,J,6)="GENERIC NAME",$E(^TMP($J,J,6),43)="VA CLASS",$E(^TMP($J,J,6),53)="CURR DEA, SPECIAL HDLG"
..S ^TMP($J,J,7)=UL,^TMP($J,J,8)="",XX=9
.D:J=4
..S ^TMP($J,J,1)="The following pharmacy orderable items are associated with active dispense"
..S ^TMP($J,J,2)="drugs that have a discrepancy within their DEA Special Hdlg fields. Please"
..S ^TMP($J,J,3)="correct all entries to identify these orderable items with a specific"
..S ^TMP($J,J,5)="Controlled Substance schedule."
..S ^TMP($J,J,6)=""
..S ^TMP($J,J,7)="PHARMACY ORDERABLE ITEM"
..S ^TMP($J,J,8)=" IEN DISPENSE DRUG",$E(^TMP($J,J,8),52)="DEA SPEC. HDLG",$E(^TMP($J,J,8),67)="CS FED. SCHE."
..S ^TMP($J,J,9)=UL,^TMP($J,J,10)="",XX=11
.F S K=$O(^XTMP(ZZ,$J,J,K)) Q:K="" D
..S:J'=4 QQ=^XTMP(ZZ,$J,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
.S XMY(DUZ)="",XMDUZ="Patch # - DEA/PKI Post-Install"
.I $D(^XUSEC("PSNMGR")) F I=0:0 S I=$O(^XUSEC("PSNMGR",I)) Q:'I S XMY(I)=""
.I J=1 S XMSUB="CS FEDERAL SCHEDULE AND DEA, SPECIAL HDLG DISCREPANCIES"
.I J=2 S XMSUB="CONTROLLED SUBSTANCES NOT MATCHED"
.I J=3 S XMSUB="CONTROLLED SUBSTANCES NOT SET CORRECTLY"
.I J=4 S XMSUB="DISCREPANCY IN DEA WITHIN DRUGS TIED TO AN OI"
.S XMTEXT="^TMP($J,J," N DIFROM D ^XMD K XMY,^TMP($J,J)
END K ^XTMP(ZZ,$J),^TMP($J),XMY,XMDUZ
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,$J,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,J,K,I)) Q:'I S QQ=$G(^XTMP(ZZ,$J,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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPKIPI 5718 printed Nov 22, 2024@17:43:50 Page 2
PSSPKIPI ;BIR/MHA-DEA/PKI Post-Inst DEA-CS FED SCH mismatch report ;08/08/02
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**61**;9/30/97
+2 ;Reference to ^PSNDF(50.68 supported by DBIA 3735
START ;
+1 SET ZZ="PSSPKI"
+2 KILL ^XTMP(ZZ,$JOB)
NEW PSSX,PSSD,PSSJ,PSSK,PSSN,NDR
+3 SET PSSX=""
FOR
SET PSSX=$ORDER(^PSDRUG("B",PSSX))
if PSSX=""
QUIT
Begin DoDot:1
+4 SET PSSN=0
FOR
SET PSSN=$ORDER(^PSDRUG("B",PSSX,PSSN))
if 'PSSN
QUIT
Begin DoDot:2
+5 if '$DATA(^PSDRUG(PSSN,0))
QUIT
+6 IF $PIECE($GET(^PSDRUG(PSSN,"I")),"^")
IF $PIECE($GET(^("I")),"^")<DT
QUIT
+7 ;Q:$P($G(^PSDRUG(PSSN,2)),"^",3)'["O"
+8 SET PSSD=$PIECE($GET(^PSDRUG(PSSN,0)),"^",3)
IF PSSD=""
DO GCS
QUIT
+9 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
+10 IF PSSD["A"&(PSSD["C")
IF +PSSD=2!(+PSSD=3)
SET PSSJ=3
QUIT
+11 SET PSSL=""
SET PSSK=$PIECE($GET(^PSDRUG(PSSN,"ND")),"^",3)
IF 'PSSK
SET PSSJ=2
QUIT
+12 SET PSSL=$$GET1^DIQ(50.68,PSSK,19,"I")
if 'PSSL
QUIT
+13 SET PSSL=$EXTRACT(PSSL)_$SELECT(PSSL["n":"C",+PSSL=2!(+PSSL=3):"A",1:"")
+14 IF $LENGTH(PSSL)=1
IF PSSD[PSSL
QUIT
+15 IF PSSD[$EXTRACT(PSSL)
IF PSSD[$EXTRACT(PSSL,2)
QUIT
+16 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
+17 DO REP4
DO SM
QUIT
+18 ;
GCS SET PSSL=""
SET PSSK=$PIECE($GET(^PSDRUG(PSSN,"ND")),"^",3)
if 'PSSK
QUIT
+1 SET PSSL=$$GET1^DIQ(50.68,PSSK,19,"I")
if 'PSSL
QUIT
+2 SET PSSL=$EXTRACT(PSSL)_$SELECT(PSSL["n":"C",+PSSL=2!(+PSSL=3):"A",1:"")
+3 if +PSSL
SET $PIECE(^PSDRUG(PSSN,0),"^",3)=PSSL
+4 QUIT
+5 ;
REP SET ^XTMP(ZZ,$JOB,PSSJ,PSSX)=NDR_"^"_$PIECE($GET(^PSDRUG(PSSN,0)),"^",2)_"^"_PSSD_$SELECT(PSSJ=1:"^"_PSSL,1:"")
+1 QUIT
SM KILL ^TMP($JOB),XMY
+1 FOR J=1,2,3,4
IF $DATA(^XTMP(ZZ,$JOB,J))
Begin DoDot:1
+2 NEW S1,S2
SET $EXTRACT(S1,42)=""
SET $EXTRACT(S2,12)=""
SET K=""
SET $PIECE(UL,"=",79)=""
+3 if J=1
Begin DoDot:2
+4 SET ^TMP($JOB,J,1)="The following active Controlled Substances were identified as having a"
+5 SET ^TMP($JOB,J,2)="discrepancy between the CS FEDERAL SCHEDULE in the VA PRODUCT file (#50.68)"
+6 SET ^TMP($JOB,J,3)="and the DEA,SPECIAL HDLG code in the DRUG file (#50). You may wish to update"
+7 SET ^TMP($JOB,J,4)="the DEA,SPECIAL HDLG code for these drugs."
+8 SET ^TMP($JOB,J,5)=""
+9 SET ^TMP($JOB,J,6)="PLEASE NOTE: The CS FEDERAL SCHEDULE will only identify DEA, SPECIAL HDLG"
+10 SET ^TMP($JOB,J,8)="codes of 1, 2A, 2C, 3A, 3C, 4, or 5. In addition to these codes, you may"
+11 SET ^TMP($JOB,J,9)="also use other DEA, SPECIAL HDLG codes such as L, P,R, S, etc., as needed."
+12 SET ^TMP($JOB,J,10)=""
SET XX=11
End DoDot:2
+13 if J=2
Begin DoDot:2
+14 SET ^TMP($JOB,J,1)="The following active Controlled Substances have not been matched to NDF."
+15 SET ^TMP($JOB,J,2)="You may wish to match these drugs."
+16 SET ^TMP($JOB,J,5)=""
+17 SET ^TMP($JOB,J,6)="GENERIC NAME"
SET $EXTRACT(^TMP($JOB,J,6),43)="VA CLASS"
SET $EXTRACT(^TMP($JOB,J,6),53)="CURR DEA, SPECIAL HDLG"
+18 SET ^TMP($JOB,J,7)=UL
SET ^TMP($JOB,J,8)=""
SET XX=9
End DoDot:2
+19 if J=3
Begin DoDot:2
+20 SET ^TMP($JOB,J,1)="The following active drugs are defined as Controlled Substances, but"
+21 SET ^TMP($JOB,J,2)="not classified correctly as Narcotics or Non-Narcotics."
+22 SET ^TMP($JOB,J,3)="Please make sure they are defined correctly."
+23 SET ^TMP($JOB,J,5)=""
+24 SET ^TMP($JOB,J,6)="GENERIC NAME"
SET $EXTRACT(^TMP($JOB,J,6),43)="VA CLASS"
SET $EXTRACT(^TMP($JOB,J,6),53)="CURR DEA, SPECIAL HDLG"
+25 SET ^TMP($JOB,J,7)=UL
SET ^TMP($JOB,J,8)=""
SET XX=9
End DoDot:2
+26 if J=4
Begin DoDot:2
+27 SET ^TMP($JOB,J,1)="The following pharmacy orderable items are associated with active dispense"
+28 SET ^TMP($JOB,J,2)="drugs that have a discrepancy within their DEA Special Hdlg fields. Please"
+29 SET ^TMP($JOB,J,3)="correct all entries to identify these orderable items with a specific"
+30 SET ^TMP($JOB,J,5)="Controlled Substance schedule."
+31 SET ^TMP($JOB,J,6)=""
+32 SET ^TMP($JOB,J,7)="PHARMACY ORDERABLE ITEM"
+33 SET ^TMP($JOB,J,8)=" IEN DISPENSE DRUG"
SET $EXTRACT(^TMP($JOB,J,8),52)="DEA SPEC. HDLG"
SET $EXTRACT(^TMP($JOB,J,8),67)="CS FED. SCHE."
+34 SET ^TMP($JOB,J,9)=UL
SET ^TMP($JOB,J,10)=""
SET XX=11
End DoDot:2
+35 FOR
SET K=$ORDER(^XTMP(ZZ,$JOB,J,K))
if K=""
QUIT
Begin DoDot:2
+36 if J'=4
SET QQ=^XTMP(ZZ,$JOB,J,K)
+37 IF J=1
DO PDET
QUIT
+38 IF J=4
DO REPN
QUIT
+39 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
+40 SET XMY(DUZ)=""
SET XMDUZ="Patch # - DEA/PKI Post-Install"
+41 IF $DATA(^XUSEC("PSNMGR"))
FOR I=0:0
SET I=$ORDER(^XUSEC("PSNMGR",I))
if 'I
QUIT
SET XMY(I)=""
+42 IF J=1
SET XMSUB="CS FEDERAL SCHEDULE AND DEA, SPECIAL HDLG DISCREPANCIES"
+43 IF J=2
SET XMSUB="CONTROLLED SUBSTANCES NOT MATCHED"
+44 IF J=3
SET XMSUB="CONTROLLED SUBSTANCES NOT SET CORRECTLY"
+45 IF J=4
SET XMSUB="DISCREPANCY IN DEA WITHIN DRUGS TIED TO AN OI"
+46 SET XMTEXT="^TMP($J,J,"
NEW DIFROM
DO ^XMD
KILL XMY,^TMP($JOB,J)
End DoDot:1
END KILL ^XTMP(ZZ,$JOB),^TMP($JOB),XMY,XMDUZ
+1 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,$JOB,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,$JOB,J,K,I))
if 'I
QUIT
SET QQ=$GET(^XTMP(ZZ,$JOB,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
