Routine: APSQAWP

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

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

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

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

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

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

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

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

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*")

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

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

APSQAWP.m