APSQAWP ;IHS/DSD/ENM - MATCH LOCAL NDC WITH FACTS & COMPARISON NDC ; [ 08/29/2003 3:11 PM ]
;;6.0;IHS PHARMACY MODIFICATIONS;**3,4**;11/11/2002
;TRIGGERED FROM NDC FIELD OF DRUG FILE UPDATE AWP,AAC 11/11/2002
;THIS WAS THE APSQAWP2 ROUTINE
Q
;
VSET I $D(^PSDRUG(APSPIRN,"I")) Q ;QUIT IF DRUG IS INACTIVE
K XMB ;BE SAFE
S XMB(9)=$S($G(DUZ)>0:$P($G(^VA(200,DUZ,0)),"^",1),1:"UNKNOWN") ;PERSON UPDATING
S APSQCNT=0 ;A COUNTER FOR ENTRIES IN BULLETIN
S APSDNAME=$P(^PSDRUG(APSPIRN,0),"^")
S APSPNDC2=""
I $L(APSPNDC)=11 S APSPNDC2=APSPNDC
I $L(APSPNDC)<11 D ;
.I $L(APSPNDC)=10 S APSPNDC2="0"_APSPNDC
;I $L(APSPNDC)=9 S APSPNDC2="00"_APSPNDC
I $L(APSPNDC)<10!($L(APSPNDC)>11) S APSPERR=4 D ERR ;NDC < 10 & > 11 DIGITS
S APSPNOD1=$S($D(^PSDRUG(APSPIRN,660)):^PSDRUG(APSPIRN,660),1:"UNK")
I APSPNOD1="UNK" S APSPERR=1 D ERR ;660 NODE MISSING
S APSP("DISP U")=$P($G(APSPNOD1),"^",5)
I APSP("DISP U")="" S APSPERR=2 D ERR ;DISPENSE UNIT MISSING
;LOOK IN APSAMDF FOR A MATCHING NDC
S APSA("MEDI-IRN")=0,APSA("TNDC")=0
I $O(^APSAMDF("B",APSPNDC2,0)) D ;
.S APSA("MEDI-IRN")=$O(^APSAMDF("B",APSPNDC2,APSA("MEDI-IRN")))
.I APSA("MEDI-IRN")]"" S APSA("TNDC")=$P(^APSAMDF(APSA("MEDI-IRN"),0),"^")
I APSA("MEDI-IRN")']""!(APSA("MEDI-IRN")=0) S APSPERR=5 D ERR Q ;NO NDC MATCH IN M-FILE
S APSA("NODE0")=^APSAMDF(APSA("MEDI-IRN"),0),APSA("NODE1")=^APSAMDF(APSA("MEDI-IRN"),1),APSA("NODE2")=^APSAMDF(APSA("MEDI-IRN"),2)
S APSA("NODE4")=$G(^APSAMDF(APSA("MEDI-IRN"),4)) ;IHS/OKCAO/POC 6/28/2002
S APSA("DISP U")=$P($G(APSA("NODE1")),"^",3) ;AWP DISP UNIT
I APSP("DISP U") I APSP("DISP U")'=APSA("DISP U") S APSPERR=3 D ERR ;DISP U 'MATCH
;GRAB AWP DATA FOR DRUG FILE UPDATE
S APSA("AWP E-DATE")=$P($G(APSA("NODE0")),"^",2),APSA("AWP-P-D-U")=$P($G(APSA("NODE0")),"^",3),APSA("AWP-P-O-U")=$P($G(APSA("NODE0")),"^",4)
S APSA("ACC-PRICE")=$P(APSA("NODE4"),U,4) ;IHS/OKCAO/POC 6/28/2002
;S APSA("ACC-SIZE")=$P(APSA("NODE4"),U,2) ;IHS/OKCAO/POC 6/28/2002
S DIE="^PSDRUG(",DA=APSPIRN,DR="9999999.31////^S X=APSA(""AWP-P-O-U"");9999999.32////^S X=APSA(""AWP-P-D-U"");9999999.33////^S X=APSA(""AWP E-DATE"")"
I +APSA("ACC-PRICE") S DR=DR_";13////^S X=APSA(""ACC-PRICE"")"
;IHS/ITSC/ENM/POC 07/09/03 POC CHANGES
;E S APSPERR=6 D ERR ;LET'S NOT QUIT BUT DO THE AWP STUFF
E D
.N APSPERR S APSPERR=6 D ERR ;DON'T QUIT BUT DO AWP STUFF
.;DON'T CHANGE APSPERR VARIABLE IF DEFINED
;I +APSA("ACC-SIZE") S DR=DR_";402////^S X=APSA(""ACC-SIZE"")"
;E S APSPERR=7 D ERR ;LET'S NOT QUIT BUT DO THE AWP STUFF
D:($G(APSPERR)>5)!('$G(APSPERR)) ^DIE ;SO DO IF ERR GR THAN 5-PROBLEM WITH AAC WHAT ABOUT WHEN APSPERR IS NOT DEFINED IHS/OKCAO/POC 12/10/2002
K DIE,DA,DR,APSA("AWP-P-O-U"),APSA("AWP-P-D-U"),APSA("AWP E-DATE")
K APSA("NODE0"),APSA("NODE1"),APSA("NODE2")
K APSA("NODE4") ;IHS/OKCAO/POC 6/28/2002
I '$G(APSPERR) S APSPERR=8 D ERR ;IHS/OKCAO/POC 7/12/2001 FOR REPORTI
Q
;
DEL ;DELETE THE AWP STUFF IF NDC DELETED IHS/OKCAO/POC
;S DIE="^PSDRUG(",DA=APSPIRN,DR="9999999.31////@;9999999.32////@;9999999.33////@"
S DIE="^PSDRUG(",DA=APSPIRN,DR="9999999.31////@;9999999.32////@;9999999.33////@;13////@" ;IHS/OKCAO/POC 6/28/2002
D ^DIE
K DIE,DA,DR
Q
ERR ;
S APSQCNT=APSQCNT+1 ;INCREASE CNT EACH TIME ERROR FOR A DRUG
;APPEND DRUG NAMES/ERROR CODES -
I APSPERR=1 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - MISSING 660 NODE IN DRUG FILE"
I APSPERR=2 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - MISSING DISPENSE UNIT IN DRUG FILE"
I APSPERR=3 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - DISP UNITS DON'T MATCH - Medi = "_APSA("DISP U")_" / Local = "_APSP("DISP U")
I APSPERR=4 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - NDC less than 10 or greater than 11 DIGITS"
I APSPERR=5 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - NDC'S DON'T MATCH"
I APSPERR=6 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - NO ACTUAL ACQUISTION PRICE FOR THIS NDC# IN THE AWP MED-TRANSACTION FILE" ;IHS/OKCAO/POC 6/28/2002
;I APSPERR=7 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - NO ACTUAL ACQUISTION SIZE FOR THIS NDC IN ACC FILE"
I APSPERR=8 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - NO PROBLEM WITH THIS PRICE UPDATE FOR AWP AND AAC" ;IHS/OKCAO/POC 7/12/2001 FOR REPORTING NO PROBLEMS
Q
MSG ;SETUP AND SEND BULLETIN
;BULLETIN ALREADY SET UP WITH XMB("ARRAY")
S XMDUZ="PHARMACY NOTIFICATION"
S XMB="APSQ DRUG AWP/AAC NOTIFICATION"
D ^XMB
Q
ZAP ;CLEAN AWP FIELD FROM DRUG - FOR USE DURING TESTING ONLY
K ^APSPCTRL("AWP DATE")
S DIE="^PSDRUG(",APSAIRN=0
F S APSAIRN=$O(^PSDRUG(APSAIRN)) Q:'APSAIRN D ;
.K DA,D0
.S DA=APSAIRN,DR="9999999.31////@;9999999.32////@;9999999.33////@"
.D ^DIE
K DIE,APSAIRN,DA,D0,DR
Q
ZAAP ;KILL ALL VARIABLES ON EXIT
K XMB,APSLNAME,APSP,APSPDG,APSPNAME,APSPZ,XMDUZ,APSA,APSDNAME,APSPERR,APSPIRN,APSPNDC,APSPNDC2,APSPNOD1,APSPNOD2,J,X,XMSUB,XMTEXT
K APSP("DISP U"),APSA("MEDI-IRN"),APSA("TNDC"),APSA("NODE0"),APSA("NODE1"),APSA("NODE2"),APSA("NODE3"),APSA("NODE4"),APSQCNT
Q
ZNDC ;EP - ENTRY POINT TO KILL AND RE-INDEX THE ^PSDRUG("ZNDC") X-REF
W !!,"Re-Indexing the 'ZNDC' x-ref in file 50..........",!
K ^PSDRUG("ZNDC") S DIK="^PSDRUG(",DIK(1)="31^ZNDC" D ENALL^DIK
K DIK
Q
SINGLE ;EP - COME HERE FOR XREF FROM FILE PSDRUG -A TRIGGER IHS/OKCAO/POC 11/12/98
Q:$D(APSQNOIN) ;MULTIPLE DIVISIONS DEFINED FROM RTN APSQRXM TO NOT REINDEX!!! IHS/OKCAO/POC 1/10/2001 PATCH 4 IHS/OKCAO/POC
S APSPIRN=DA ;IEN
S APSPNDC=$TR(X,"-")
S APSQWORK=$S($G(APSQDEL):"DEL^APSQAWP",1:"VSET^APSQAWP")
D EN^XBNEW("DO^APSQAWP","APS*")
Q
DO ;IF APSQDEL=1 THEN WILL DELETE ENTRY
;N DR,DA,D0,DD,DIE,DIC,X,Y
;SET VARIABLE
D @APSQWORK
D:'$G(APSQDEL) MSG,ZAAP
K APSQDEL,APSQWORK
Q
APSQAWP ;IHS/DSD/ENM - MATCH LOCAL NDC WITH FACTS & COMPARISON NDC ; [ 08/29/2003 3:11 PM ]
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3,4**;11/11/2002
+2 ;TRIGGERED FROM NDC FIELD OF DRUG FILE UPDATE AWP,AAC 11/11/2002
+3 ;THIS WAS THE APSQAWP2 ROUTINE
+4 QUIT
+5 ;
VSET ;QUIT IF DRUG IS INACTIVE
IF $DATA(^PSDRUG(APSPIRN,"I"))
QUIT
+1 ;BE SAFE
KILL XMB
+2 ;PERSON UPDATING
SET XMB(9)=$SELECT($GET(DUZ)>0:$PIECE($GET(^VA(200,DUZ,0)),"^",1),1:"UNKNOWN")
+3 ;A COUNTER FOR ENTRIES IN BULLETIN
SET APSQCNT=0
+4 SET APSDNAME=$PIECE(^PSDRUG(APSPIRN,0),"^")
+5 SET APSPNDC2=""
+6 IF $LENGTH(APSPNDC)=11
SET APSPNDC2=APSPNDC
+7 ;
IF $LENGTH(APSPNDC)<11
Begin DoDot:1
+8 IF $LENGTH(APSPNDC)=10
SET APSPNDC2="0"_APSPNDC
End DoDot:1
+9 ;I $L(APSPNDC)=9 S APSPNDC2="00"_APSPNDC
+10 ;NDC < 10 & > 11 DIGITS
IF $LENGTH(APSPNDC)<10!($LENGTH(APSPNDC)>11)
SET APSPERR=4
DO ERR
+11 SET APSPNOD1=$SELECT($DATA(^PSDRUG(APSPIRN,660)):^PSDRUG(APSPIRN,660),1:"UNK")
+12 ;660 NODE MISSING
IF APSPNOD1="UNK"
SET APSPERR=1
DO ERR
+13 SET APSP("DISP U")=$PIECE($GET(APSPNOD1),"^",5)
+14 ;DISPENSE UNIT MISSING
IF APSP("DISP U")=""
SET APSPERR=2
DO ERR
+15 ;LOOK IN APSAMDF FOR A MATCHING NDC
+16 SET APSA("MEDI-IRN")=0
SET APSA("TNDC")=0
+17 ;
IF $ORDER(^APSAMDF("B",APSPNDC2,0))
Begin DoDot:1
+18 SET APSA("MEDI-IRN")=$ORDER(^APSAMDF("B",APSPNDC2,APSA("MEDI-IRN")))
+19 IF APSA("MEDI-IRN")]""
SET APSA("TNDC")=$PIECE(^APSAMDF(APSA("MEDI-IRN"),0),"^")
End DoDot:1
+20 ;NO NDC MATCH IN M-FILE
IF APSA("MEDI-IRN")']""!(APSA("MEDI-IRN")=0)
SET APSPERR=5
DO ERR
QUIT
+21 SET APSA("NODE0")=^APSAMDF(APSA("MEDI-IRN"),0)
SET APSA("NODE1")=^APSAMDF(APSA("MEDI-IRN"),1)
SET APSA("NODE2")=^APSAMDF(APSA("MEDI-IRN"),2)
+22 ;IHS/OKCAO/POC 6/28/2002
SET APSA("NODE4")=$GET(^APSAMDF(APSA("MEDI-IRN"),4))
+23 ;AWP DISP UNIT
SET APSA("DISP U")=$PIECE($GET(APSA("NODE1")),"^",3)
+24 ;DISP U 'MATCH
IF APSP("DISP U")
IF APSP("DISP U")'=APSA("DISP U")
SET APSPERR=3
DO ERR
+25 ;GRAB AWP DATA FOR DRUG FILE UPDATE
+26 SET APSA("AWP E-DATE")=$PIECE($GET(APSA("NODE0")),"^",2)
SET APSA("AWP-P-D-U")=$PIECE($GET(APSA("NODE0")),"^",3)
SET APSA("AWP-P-O-U")=$PIECE($GET(APSA("NODE0")),"^",4)
+27 ;IHS/OKCAO/POC 6/28/2002
SET APSA("ACC-PRICE")=$PIECE(APSA("NODE4"),U,4)
+28 ;S APSA("ACC-SIZE")=$P(APSA("NODE4"),U,2) ;IHS/OKCAO/POC 6/28/2002
+29 SET DIE="^PSDRUG("
SET DA=APSPIRN
SET DR="9999999.31////^S X=APSA(""AWP-P-O-U"");9999999.32////^S X=APSA(""AWP-P-D-U"");9999999.33////^S X=APSA(""AWP E-DATE"")"
+30 IF +APSA("ACC-PRICE")
SET DR=DR_";13////^S X=APSA(""ACC-PRICE"")"
+31 ;IHS/ITSC/ENM/POC 07/09/03 POC CHANGES
+32 ;E S APSPERR=6 D ERR ;LET'S NOT QUIT BUT DO THE AWP STUFF
+33 IF '$TEST
Begin DoDot:1
+34 ;DON'T QUIT BUT DO AWP STUFF
NEW APSPERR
SET APSPERR=6
DO ERR
+35 ;DON'T CHANGE APSPERR VARIABLE IF DEFINED
End DoDot:1
+36 ;I +APSA("ACC-SIZE") S DR=DR_";402////^S X=APSA(""ACC-SIZE"")"
+37 ;E S APSPERR=7 D ERR ;LET'S NOT QUIT BUT DO THE AWP STUFF
+38 ;SO DO IF ERR GR THAN 5-PROBLEM WITH AAC WHAT ABOUT WHEN APSPERR IS NOT DEFINED IHS/OKCAO/POC 12/10/2002
IF ($GET(APSPERR)>5)!('$GET(APSPERR))
DO ^DIE
+39 KILL DIE,DA,DR,APSA("AWP-P-O-U"),APSA("AWP-P-D-U"),APSA("AWP E-DATE")
+40 KILL APSA("NODE0"),APSA("NODE1"),APSA("NODE2")
+41 ;IHS/OKCAO/POC 6/28/2002
KILL APSA("NODE4")
+42 ;IHS/OKCAO/POC 7/12/2001 FOR REPORTI
IF '$GET(APSPERR)
SET APSPERR=8
DO ERR
+43 QUIT
+44 ;
DEL ;DELETE THE AWP STUFF IF NDC DELETED IHS/OKCAO/POC
+1 ;S DIE="^PSDRUG(",DA=APSPIRN,DR="9999999.31////@;9999999.32////@;9999999.33////@"
+2 ;IHS/OKCAO/POC 6/28/2002
SET DIE="^PSDRUG("
SET DA=APSPIRN
SET DR="9999999.31////@;9999999.32////@;9999999.33////@;13////@"
+3 DO ^DIE
+4 KILL DIE,DA,DR
+5 QUIT
ERR ;
+1 ;INCREASE CNT EACH TIME ERROR FOR A DRUG
SET APSQCNT=APSQCNT+1
+2 ;APPEND DRUG NAMES/ERROR CODES -
+3 IF APSPERR=1
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - MISSING 660 NODE IN DRUG FILE"
+4 IF APSPERR=2
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - MISSING DISPENSE UNIT IN DRUG FILE"
+5 IF APSPERR=3
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - DISP UNITS DON'T MATCH - Medi = "_APSA("DISP U")_" / Local = "_APSP("DISP U")
+6 IF APSPERR=4
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - NDC less than 10 or greater than 11 DIGITS"
+7 IF APSPERR=5
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - NDC'S DON'T MATCH"
+8 ;IHS/OKCAO/POC 6/28/2002
IF APSPERR=6
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - NO ACTUAL ACQUISTION PRICE FOR THIS NDC# IN THE AWP MED-TRANSACTION FILE"
+9 ;I APSPERR=7 S XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$G(APSPNDC)_" - NO ACTUAL ACQUISTION SIZE FOR THIS NDC IN ACC FILE"
+10 ;IHS/OKCAO/POC 7/12/2001 FOR REPORTING NO PROBLEMS
IF APSPERR=8
SET XMB(APSQCNT)="("_APSPIRN_") "_APSDNAME_"-"_$GET(APSPNDC)_" - NO PROBLEM WITH THIS PRICE UPDATE FOR AWP AND AAC"
+11 QUIT
MSG ;SETUP AND SEND BULLETIN
+1 ;BULLETIN ALREADY SET UP WITH XMB("ARRAY")
+2 SET XMDUZ="PHARMACY NOTIFICATION"
+3 SET XMB="APSQ DRUG AWP/AAC NOTIFICATION"
+4 DO ^XMB
+5 QUIT
ZAP ;CLEAN AWP FIELD FROM DRUG - FOR USE DURING TESTING ONLY
+1 KILL ^APSPCTRL("AWP DATE")
+2 SET DIE="^PSDRUG("
SET APSAIRN=0
+3 ;
FOR
SET APSAIRN=$ORDER(^PSDRUG(APSAIRN))
IF 'APSAIRN
QUIT
Begin DoDot:1
+4 KILL DA,D0
+5 SET DA=APSAIRN
SET DR="9999999.31////@;9999999.32////@;9999999.33////@"
+6 DO ^DIE
End DoDot:1
+7 KILL DIE,APSAIRN,DA,D0,DR
+8 QUIT
ZAAP ;KILL ALL VARIABLES ON EXIT
+1 KILL XMB,APSLNAME,APSP,APSPDG,APSPNAME,APSPZ,XMDUZ,APSA,APSDNAME,APSPERR,APSPIRN,APSPNDC,APSPNDC2,APSPNOD1,APSPNOD2,J,X,XMSUB,XMTEXT
+2 KILL APSP("DISP U"),APSA("MEDI-IRN"),APSA("TNDC"),APSA("NODE0"),APSA("NODE1"),APSA("NODE2"),APSA("NODE3"),APSA("NODE4"),APSQCNT
+3 QUIT
ZNDC ;EP - ENTRY POINT TO KILL AND RE-INDEX THE ^PSDRUG("ZNDC") X-REF
+1 WRITE !!,"Re-Indexing the 'ZNDC' x-ref in file 50..........",!
+2 KILL ^PSDRUG("ZNDC")
SET DIK="^PSDRUG("
SET DIK(1)="31^ZNDC"
DO ENALL^DIK
+3 KILL DIK
+4 QUIT
SINGLE ;EP - COME HERE FOR XREF FROM FILE PSDRUG -A TRIGGER IHS/OKCAO/POC 11/12/98
+1 ;MULTIPLE DIVISIONS DEFINED FROM RTN APSQRXM TO NOT REINDEX!!! IHS/OKCAO/POC 1/10/2001 PATCH 4 IHS/OKCAO/POC
IF $DATA(APSQNOIN)
QUIT
+2 ;IEN
SET APSPIRN=DA
+3 SET APSPNDC=$TRANSLATE(X,"-")
+4 SET APSQWORK=$SELECT($GET(APSQDEL):"DEL^APSQAWP",1:"VSET^APSQAWP")
+5 DO EN^XBNEW("DO^APSQAWP","APS*")
+6 QUIT
DO ;IF APSQDEL=1 THEN WILL DELETE ENTRY
+1 ;N DR,DA,D0,DD,DIE,DIC,X,Y
+2 ;SET VARIABLE
+3 DO @APSQWORK
+4 IF '$GET(APSQDEL)
DO MSG
DO ZAAP
+5 KILL APSQDEL,APSQWORK
+6 QUIT
