APSAWP2 ;IHS/DSD/ENM - MATCH LOCAL NDC WITH FACTS/COMPARISONS NDC ;03-Jan-2012 19:26;PLS
;;7.0;IHS PHARMACY MODIFICATIONS;**1013**;11/11/2002;Build 33
;MODIFIED FOR ACTUAL ACQUISTION COST ENTRY
; Modified - IHS/CIA/PLS - 01/13/04 - Added AUTOQ API, MANU+2(Prompt for manual update)
; IHS/MSC/PLS - 12/01/11 - Changes AWP references to Benchmark Pricing
EP ;EP ENTRY POINT FOR NIGHTLY QUEUE
S:'$D(PSOSITE) PSOSITE=$O(^PS(59,"C",DUZ(2),"")) ;IHS/OKCAO/POC 4/10/2001 SET FOR DECIDING IF THIS DIVISION PATCH 4
K ^TMP($J,"PSOERR")
I '$D(^PSDRUG("ZNDC")) Q
I $D(^APSAMDF("DATE"))="" Q
I '$D(^APSPCTRL("AWP DATE"))&($D(^APSAMDF("DATE"))) G P1
S APSP("CTRL DATE")=^APSPCTRL("AWP DATE")
S APSP("MEDI-DATE")=^APSAMDF("DATE")
I APSP("MEDI-DATE")'>APSP("CTRL DATE") Q
;
;IHS/ITSC/ENM 01/13/03 CONVERT DATE TO READABLE FORM
P1 ;D NOW^%DTC S APSP("RUN DATE")=X
D NOW^%DTC S Y=X X ^DD("DD") S APSP("RUN DATE")=Y
S APSP("NEW DATE")=^APSAMDF("DATE")
S APSPERR="",APSPNDC=0,APSPIRN=0,APSPNOD1="",APSPNOD2="",APSP("TOTAL REC")=0,APSDNAME=""
S APSPNOD4="" ;IHS/OKCAO/POC 6/28/2002
;F S APSPNDC=$O(^PSDRUG("ZNDC",APSPNDC)) Q:'APSPNDC F S APSPIRN=$O(^PSDRUG("ZNDC",APSPNDC,APSPIRN)) Q:'APSPIRN D VSET ;
F S APSPNDC=$O(^PSDRUG("ZNDC",APSPNDC)) Q:APSPNDC="" F S APSPIRN=$O(^PSDRUG("ZNDC",APSPNDC,APSPIRN)) Q:APSPIRN="" D VSET ; CHANGED BECAUSE APSPIRN MIGHT BE 0 IHS/OKCAO/POC 1/8/99
S ^APSPCTRL("AWP DATE")=APSP("NEW DATE") ;SET AWP DATE IN CTRL FILE
;IHS/ITSC/ENM 02/25/03 NEXT TWO LINES ADDED
S ^APSPCTRL("AWP UPDATE COUNT")=APSP("TOTAL REC")
D NOW^%DTC S ^APSPCTRL("AWP LAST U-DATE")=%
;ENTER CALL TO MSG MODULE
D MSG
D ZAAP
Q
VSET I $D(^PSDRUG(APSPIRN,"I")) Q ;QUIT IF DRUG IS INACTIVE
;Q:$P(^PSDRUG(APSPIRN,9999999),"^",3)'=+PSOSITE ;QUIT IF NOT THIS DIVISION IHS/OKCAO/POC/POC 4/10/2001 PATCH 4
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 ETRAP Q ;NDC < 10 & > 11 DIGITS
S APSPNOD1=$S($D(^PSDRUG(APSPIRN,660)):^PSDRUG(APSPIRN,660),1:"UNK")
I APSPNOD1="UNK" S APSPERR=1 D ETRAP Q ;660 NODE MISSING
S APSP("DISP U")=$P($G(APSPNOD1),"^",5)
I APSP("DISP U")="" S APSPERR=2 D ETRAP Q ;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 ETRAP Q ;NO NDC MATCH IN M-FILE
;I APSA("MEDI-IRN")=0 S APSPERR=5 D ETRAP 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")'=APSA("DISP U") S APSPERR=3 D ETRAP Q ;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"")"
;MORE CHANGES IHS/OKCAO/POC 6/28/2002
I +APSA("ACC-PRICE") S DR=DR_";13////^S X=APSA(""ACC-PRICE"")"
;E S APSPERR=6 D ETRAP Q
E S APSPERR=6 D ETRAP ;LET'S DO THE AWP STUFF
;I +APSA("ACC-SIZE") S DR=DR_";402////^S X=APSA(""ACC-SIZE"")"
;E S APSPERR=7 D ETRAP Q
;E S APSPERR=7 D ETRAP ;LET'S DO THE AWP STUFF
;END OF CHANGES IHS/OKCAO/POC 6/28/2002
D ^DIE
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
S APSP("TOTAL REC")=APSP("TOTAL REC")+1
Q
ETRAP ;
;CAPTURE ALL DRUGS THAT CAN'T BE UPDATED AND INCLUDE IN MAIL MESSAGE
;CHANGED TWO LINES SORT BY APSPERR IHS/OKCAO/POC 8/30/2003
;S ^TMP($J,"PSOERR",APSDNAME,APSPIRN)=APSPNDC_"^"_APSPERR
;I APSPERR=3 S $P(^TMP($J,"PSOERR",APSDNAME,APSPIRN),"^",3)=APSP("DISP U"),$P(^TMP($J,"PSOERR",APSDNAME,APSPIRN),"^",4)=APSA("DISP U")
S ^TMP($J,"PSOERR",APSPERR,APSDNAME,APSPIRN)=APSPNDC_"^"_APSPERR
I APSPERR=3 S $P(^TMP($J,"PSOERR",APSPERR,APSDNAME,APSPIRN),"^",3)=APSP("DISP U"),$P(^TMP($J,"PSOERR",APSPERR,APSDNAME,APSPIRN),"^",4)=APSA("DISP U")
S APSPERR=""
Q
ERR ;
;APPEND DRUG NAMES/ERROR CODES -
I APSP("ERR")=1 S APSPMSG(APSPZ,0)=APSPDG_" - MISSING 660 NODE IN DRUG FILE"
I APSP("ERR")=2 S APSPMSG(APSPZ,0)=APSPDG_" - MISSING DISPENSE UNIT IN DRUG FILE"
I APSP("ERR")=3 S APSPMSG(APSPZ,0)=APSPDG_" - DISP UNITS DON'T MATCH - Medi = "_APSP("MEDI")_" / Local = "_APSP("LOC")
I APSP("ERR")=4 S APSPMSG(APSPZ,0)=APSPDG_" - NDC less than 10 or greater than 11 DIGITS"
I APSP("ERR")=5 S APSPMSG(APSPZ,0)=APSPDG_" - NDC'S DON'T MATCH"
;CHANGES IHS/OKCAO/POC 6/28/2002
I APSP("ERR")=6 S APSPMSG(APSPZ,0)=APSPDG_" - NO ACTUAL ACQUISTION PRICE FOR THIS NDC IN AWP MED-TRANSACTION FILE"
;I APSP("ERR")=7 S APSPMSG(APSPZ,0)=APSPDG_" - NO ACTUAL ACQUISTION SIZE FOR THIS NDC IN ACC FILE"
;END OF CHANGES IHS/OKCAO/POC 6/28/2002
S APSPZ=APSPZ+1
Q
MSG ;SETUP AND SEND EMAIL MSG - LOOP ON ^TMP
D XMSET
D TEXT
S APSP("TMPRN")=0,APSPZ=11,APSLNM=""
;ADD VARIABLE APSPERR AND CHANGE NEXT LINE ADD SORT APSPERR IHS/OKCAO/POC 8/30/2003
S APSPERR=0 ;IHS/OKCAO/POC 8/30/2003
;F S APSLNM=$O(^TMP($J,"PSOERR",APSLNM)) Q:APSLNM=-1!(APSLNM']"") F S APSP("TMPRN")=$O(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN"))) Q:'APSP("TMPRN") D APSPGN
F S APSPERR=$O(^TMP($J,"PSOERR",APSPERR)) Q:APSPERR'=+APSPERR F S APSLNM=$O(^TMP($J,"PSOERR",APSPERR,APSLNM)) Q:APSLNM=-1!(APSLNM']"") F S APSP("TMPRN")=$O(^TMP($J,"PSOERR",APSPERR,APSLNM,APSP("TMPRN"))) Q:'APSP("TMPRN") D APSPGN
D MSG1
Q
APSPGN ;GET DRUG NAME FOR EMAIL MSG
;SORT BY APSPERR IHS/OKCAO/POC 8/30/2003
;S APSP("ERR")=$P($G(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN"))),"^",2),APSPDG=APSLNM
;I APSP("ERR")=3 S APSP("MEDI")=$P(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN")),"^",4),APSP("LOC")=$P(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN")),"^",3)
S APSP("ERR")=$P($G(^TMP($J,"PSOERR",APSPERR,APSLNM,APSP("TMPRN"))),"^",2),APSPDG=APSLNM
I APSP("ERR")=3 S APSP("MEDI")=$P(^TMP($J,"PSOERR",APSPERR,APSLNM,APSP("TMPRN")),"^",4),APSP("LOC")=$P(^TMP($J,"PSOERR",APSPERR,APSLNM,APSP("TMPRN")),"^",3)
D ERR ;GET ERROR CODE
I APSPZ>200 D MSG1,XMSET,TEXT S APSPZ=11
Q
XMSET ;SET MAIL VARIABLES
;K XMY S XMSUB="Outpatient Pharmacy AWP Automatic Update",XMDUZ="OUTPATIENT PHARMACY DEVELOPER"
K XMY S XMSUB="Outpatient Pharmacy Benchmark Price Automatic Update",XMDUZ="OUTPATIENT PHARMACY DEVELOPER" ;IHS/OIT/CLS 11/28/2011 patch 1013
D RPH
Q
MSG1 D ^XMD K APSPMSG
Q
TEXT S APSPMSG(1,0)="A Pricing update was performed on your system on "_APSP("RUN DATE")_".",APSPMSG(2,0)="The total number of records updated = "_APSP("TOTAL REC"),APSPMSG(3,0)="" ;CHANGED THE WORDING 6/28/2002 IHS/OKCAO/POC
S APSPMSG(4,0)="Listed below are the active drugs that were not updated and the error codes."
S APSPMSG(5,0)="Please review and correct all errors before attempting to run the manual "
;S APSPMSG(6,0)="AWP update option."
S APSPMSG(6,0)="Benchmark Price update option." ;IHS/OIT/CLS 11/28/2011 patch 1013
S APSPMSG(7,0)="Note: any 'missing 660 node' errors means that information like (ie. Reorder"
S APSPMSG(8,0)=" Level, Order Unit, Price Per Order Unit, Dispense Units Per"
S APSPMSG(9,0)=" Order unit, Price Per Dispense Unit, etc) is missing!"
S APSPMSG(10,0)=" "
S XMTEXT="APSPMSG(",%H=$H D YX^%DTC
Q
RPH ;GET HOLDERS OF 'PSOMCORE' (PHARMACIST)
;S XMY("MOORE,EDGAR")="" Q ;TEMPORARY, REMOVE AFTER TESTING
S J=0
F J=0:0 S J=$O(^XUSEC("PSOMCORE",J)) Q:'J S APSPNAME=$P($G(^VA(200,J,0)),"^"),XMY(APSPNAME)=""
;F J=0:0 S J=$O(^XUSEC("AZOAWPGLORES",J)) Q:'J S APSPNAME=$P($G(^VA(200,J,0)),"^"),XMY(APSPNAME)="" ;IHS/OKCAO/POC 6/22/98 CHANGE SECURITY KEY
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 ^TMP($J,"PSOERR"),APSLNM,APSP,APSPDG,APSPNAME,APSPZ,XMDUZ,APSA,APSDNAME,APSPERR,APSPIRN,APSPNDC,APSPNDC2,APSPNOD1,APSPNOD2,J,X,XMSUB,XMTEXT
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
MANU ;EP - ENTRY POINT FOR PHARMACIST TO USE AFTER FIXING DRUGS
K ^TMP($J,"PSOERR")
N DIR
S DIR(0)="Y",DIR("A")="Perform Update",DIR("B")="NO" D ^DIR
Q:'Y
;W !,"AWP Update in progress, Please hold on........."
W !,"Benchmark Price Update in progress, Please hold on........." ;IHS/OIT/CLS 11/28/2011 patch 1013
;I '$D(^APSAMDF("DATE")) W !,*7,"No Medi-Span database loaded......quitting!!",! H 5 Q
I '$D(^APSAMDF("DATE")) W !,*7,"No Facts & Comparisons database loaded......quitting!!",! H 5 Q
D P1
D ZAAP
;W !,"AWP Update done!! Please check your mail for any error messages",!
W !,"Benchmark Price Update done!! Please check your mail for any error messages",! ;IHS/OIT/CLS 11/28/2011 patch 2013
Q
; IHS/CIA/PLS - 01/13/04
AUTOQ ;EP - ENTRY POINT FOR AUTO QUEUEING OF APSA AWP AUTO QUEUE OPTION
Q:'$$FIND1^DIC(19,"","MX","APSA AWP AUTO QUEUE")
I $$FIND1^DIC(19.2,"","MX","APSA AWP AUTO QUEUE") D
.D EDIT^XUTMOPT("APSA AWP AUTO QUEUE")
E D
.D RESCH^XUTMOPT("APSA AWP AUTO QUEUE","","","24H","L")
.D EDIT^XUTMOPT("APSA AWP AUTO QUEUE")
Q
APSAWP2 ;IHS/DSD/ENM - MATCH LOCAL NDC WITH FACTS/COMPARISONS NDC ;03-Jan-2012 19:26;PLS
+1 ;;7.0;IHS PHARMACY MODIFICATIONS;**1013**;11/11/2002;Build 33
+2 ;MODIFIED FOR ACTUAL ACQUISTION COST ENTRY
+3 ; Modified - IHS/CIA/PLS - 01/13/04 - Added AUTOQ API, MANU+2(Prompt for manual update)
+4 ; IHS/MSC/PLS - 12/01/11 - Changes AWP references to Benchmark Pricing
EP ;EP ENTRY POINT FOR NIGHTLY QUEUE
+1 ;IHS/OKCAO/POC 4/10/2001 SET FOR DECIDING IF THIS DIVISION PATCH 4
IF '$DATA(PSOSITE)
SET PSOSITE=$ORDER(^PS(59,"C",DUZ(2),""))
+2 KILL ^TMP($JOB,"PSOERR")
+3 IF '$DATA(^PSDRUG("ZNDC"))
QUIT
+4 IF $DATA(^APSAMDF("DATE"))=""
QUIT
+5 IF '$DATA(^APSPCTRL("AWP DATE"))&($DATA(^APSAMDF("DATE")))
GOTO P1
+6 SET APSP("CTRL DATE")=^APSPCTRL("AWP DATE")
+7 SET APSP("MEDI-DATE")=^APSAMDF("DATE")
+8 IF APSP("MEDI-DATE")'>APSP("CTRL DATE")
QUIT
+9 ;
+10 ;IHS/ITSC/ENM 01/13/03 CONVERT DATE TO READABLE FORM
P1 ;D NOW^%DTC S APSP("RUN DATE")=X
+1 DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
SET APSP("RUN DATE")=Y
+2 SET APSP("NEW DATE")=^APSAMDF("DATE")
+3 SET APSPERR=""
SET APSPNDC=0
SET APSPIRN=0
SET APSPNOD1=""
SET APSPNOD2=""
SET APSP("TOTAL REC")=0
SET APSDNAME=""
+4 ;IHS/OKCAO/POC 6/28/2002
SET APSPNOD4=""
+5 ;F S APSPNDC=$O(^PSDRUG("ZNDC",APSPNDC)) Q:'APSPNDC F S APSPIRN=$O(^PSDRUG("ZNDC",APSPNDC,APSPIRN)) Q:'APSPIRN D VSET ;
+6 ; CHANGED BECAUSE APSPIRN MIGHT BE 0 IHS/OKCAO/POC 1/8/99
FOR
SET APSPNDC=$ORDER(^PSDRUG("ZNDC",APSPNDC))
IF APSPNDC=""
QUIT
FOR
SET APSPIRN=$ORDER(^PSDRUG("ZNDC",APSPNDC,APSPIRN))
IF APSPIRN=""
QUIT
DO VSET
+7 ;SET AWP DATE IN CTRL FILE
SET ^APSPCTRL("AWP DATE")=APSP("NEW DATE")
+8 ;IHS/ITSC/ENM 02/25/03 NEXT TWO LINES ADDED
+9 SET ^APSPCTRL("AWP UPDATE COUNT")=APSP("TOTAL REC")
+10 DO NOW^%DTC
SET ^APSPCTRL("AWP LAST U-DATE")=%
+11 ;ENTER CALL TO MSG MODULE
+12 DO MSG
+13 DO ZAAP
+14 QUIT
VSET ;QUIT IF DRUG IS INACTIVE
IF $DATA(^PSDRUG(APSPIRN,"I"))
QUIT
+1 ;Q:$P(^PSDRUG(APSPIRN,9999999),"^",3)'=+PSOSITE ;QUIT IF NOT THIS DIVISION IHS/OKCAO/POC/POC 4/10/2001 PATCH 4
+2 SET APSDNAME=$PIECE(^PSDRUG(APSPIRN,0),"^")
+3 SET APSPNDC2=""
+4 IF $LENGTH(APSPNDC)=11
SET APSPNDC2=APSPNDC
+5 ;
IF $LENGTH(APSPNDC)<11
Begin DoDot:1
+6 IF $LENGTH(APSPNDC)=10
SET APSPNDC2="0"_APSPNDC
End DoDot:1
+7 ;I $L(APSPNDC)=9 S APSPNDC2="00"_APSPNDC
+8 ;NDC < 10 & > 11 DIGITS
IF $LENGTH(APSPNDC)<10!($LENGTH(APSPNDC)>11)
SET APSPERR=4
DO ETRAP
QUIT
+9 SET APSPNOD1=$SELECT($DATA(^PSDRUG(APSPIRN,660)):^PSDRUG(APSPIRN,660),1:"UNK")
+10 ;660 NODE MISSING
IF APSPNOD1="UNK"
SET APSPERR=1
DO ETRAP
QUIT
+11 SET APSP("DISP U")=$PIECE($GET(APSPNOD1),"^",5)
+12 ;DISPENSE UNIT MISSING
IF APSP("DISP U")=""
SET APSPERR=2
DO ETRAP
QUIT
+13 ;LOOK IN APSAMDF FOR A MATCHING NDC
+14 SET APSA("MEDI-IRN")=0
SET APSA("TNDC")=0
+15 ;
IF $ORDER(^APSAMDF("B",APSPNDC2,0))
Begin DoDot:1
+16 SET APSA("MEDI-IRN")=$ORDER(^APSAMDF("B",APSPNDC2,APSA("MEDI-IRN")))
+17 IF APSA("MEDI-IRN")]""
SET APSA("TNDC")=$PIECE(^APSAMDF(APSA("MEDI-IRN"),0),"^")
End DoDot:1
+18 ;NO NDC MATCH IN M-FILE
IF APSA("MEDI-IRN")']""!(APSA("MEDI-IRN")=0)
SET APSPERR=5
DO ETRAP
QUIT
+19 ;I APSA("MEDI-IRN")=0 S APSPERR=5 D ETRAP Q ;NO NDC MATCH IN M-FILE
+20 SET APSA("NODE0")=^APSAMDF(APSA("MEDI-IRN"),0)
SET APSA("NODE1")=^APSAMDF(APSA("MEDI-IRN"),1)
SET APSA("NODE2")=^APSAMDF(APSA("MEDI-IRN"),2)
+21 ;IHS/OKCAO/POC 6/28/2002
SET APSA("NODE4")=$GET(^APSAMDF(APSA("MEDI-IRN"),4))
+22 ;AWP DISP UNIT
SET APSA("DISP U")=$PIECE($GET(APSA("NODE1")),"^",3)
+23 ;DISP U 'MATCH
IF APSP("DISP U")'=APSA("DISP U")
SET APSPERR=3
DO ETRAP
QUIT
+24 ;GRAB AWP DATA FOR DRUG FILE UPDATE
+25 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)
+26 ;IHS/OKCAO/POC 6/28/2002
SET APSA("ACC-PRICE")=$PIECE(APSA("NODE4"),U,4)
+27 ;S APSA("ACC-SIZE")=$P(APSA("NODE4"),U,2) ;IHS/OKCAO/POC 6/28/2002
+28 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"")"
+29 ;MORE CHANGES IHS/OKCAO/POC 6/28/2002
+30 IF +APSA("ACC-PRICE")
SET DR=DR_";13////^S X=APSA(""ACC-PRICE"")"
+31 ;E S APSPERR=6 D ETRAP Q
+32 ;LET'S DO THE AWP STUFF
IF '$TEST
SET APSPERR=6
DO ETRAP
+33 ;I +APSA("ACC-SIZE") S DR=DR_";402////^S X=APSA(""ACC-SIZE"")"
+34 ;E S APSPERR=7 D ETRAP Q
+35 ;E S APSPERR=7 D ETRAP ;LET'S DO THE AWP STUFF
+36 ;END OF CHANGES IHS/OKCAO/POC 6/28/2002
+37 DO ^DIE
+38 KILL DIE,DA,DR,APSA("AWP-P-O-U"),APSA("AWP-P-D-U"),APSA("AWP E-DATE")
+39 KILL APSA("NODE0"),APSA("NODE1"),APSA("NODE2")
+40 ;IHS/OKCAO/POC 6/28/2002
KILL APSA("NODE4")
+41 SET APSP("TOTAL REC")=APSP("TOTAL REC")+1
+42 QUIT
ETRAP ;
+1 ;CAPTURE ALL DRUGS THAT CAN'T BE UPDATED AND INCLUDE IN MAIL MESSAGE
+2 ;CHANGED TWO LINES SORT BY APSPERR IHS/OKCAO/POC 8/30/2003
+3 ;S ^TMP($J,"PSOERR",APSDNAME,APSPIRN)=APSPNDC_"^"_APSPERR
+4 ;I APSPERR=3 S $P(^TMP($J,"PSOERR",APSDNAME,APSPIRN),"^",3)=APSP("DISP U"),$P(^TMP($J,"PSOERR",APSDNAME,APSPIRN),"^",4)=APSA("DISP U")
+5 SET ^TMP($JOB,"PSOERR",APSPERR,APSDNAME,APSPIRN)=APSPNDC_"^"_APSPERR
+6 IF APSPERR=3
SET $PIECE(^TMP($JOB,"PSOERR",APSPERR,APSDNAME,APSPIRN),"^",3)=APSP("DISP U")
SET $PIECE(^TMP($JOB,"PSOERR",APSPERR,APSDNAME,APSPIRN),"^",4)=APSA("DISP U")
+7 SET APSPERR=""
+8 QUIT
ERR ;
+1 ;APPEND DRUG NAMES/ERROR CODES -
+2 IF APSP("ERR")=1
SET APSPMSG(APSPZ,0)=APSPDG_" - MISSING 660 NODE IN DRUG FILE"
+3 IF APSP("ERR")=2
SET APSPMSG(APSPZ,0)=APSPDG_" - MISSING DISPENSE UNIT IN DRUG FILE"
+4 IF APSP("ERR")=3
SET APSPMSG(APSPZ,0)=APSPDG_" - DISP UNITS DON'T MATCH - Medi = "_APSP("MEDI")_" / Local = "_APSP("LOC")
+5 IF APSP("ERR")=4
SET APSPMSG(APSPZ,0)=APSPDG_" - NDC less than 10 or greater than 11 DIGITS"
+6 IF APSP("ERR")=5
SET APSPMSG(APSPZ,0)=APSPDG_" - NDC'S DON'T MATCH"
+7 ;CHANGES IHS/OKCAO/POC 6/28/2002
+8 IF APSP("ERR")=6
SET APSPMSG(APSPZ,0)=APSPDG_" - NO ACTUAL ACQUISTION PRICE FOR THIS NDC IN AWP MED-TRANSACTION FILE"
+9 ;I APSP("ERR")=7 S APSPMSG(APSPZ,0)=APSPDG_" - NO ACTUAL ACQUISTION SIZE FOR THIS NDC IN ACC FILE"
+10 ;END OF CHANGES IHS/OKCAO/POC 6/28/2002
+11 SET APSPZ=APSPZ+1
+12 QUIT
MSG ;SETUP AND SEND EMAIL MSG - LOOP ON ^TMP
+1 DO XMSET
+2 DO TEXT
+3 SET APSP("TMPRN")=0
SET APSPZ=11
SET APSLNM=""
+4 ;ADD VARIABLE APSPERR AND CHANGE NEXT LINE ADD SORT APSPERR IHS/OKCAO/POC 8/30/2003
+5 ;IHS/OKCAO/POC 8/30/2003
SET APSPERR=0
+6 ;F S APSLNM=$O(^TMP($J,"PSOERR",APSLNM)) Q:APSLNM=-1!(APSLNM']"") F S APSP("TMPRN")=$O(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN"))) Q:'APSP("TMPRN") D APSPGN
+7 FOR
SET APSPERR=$ORDER(^TMP($JOB,"PSOERR",APSPERR))
IF APSPERR'=+APSPERR
QUIT
FOR
SET APSLNM=$ORDER(^TMP($JOB,"PSOERR",APSPERR,APSLNM))
IF APSLNM=-1!(APSLNM']"")
QUIT
FOR
SET APSP("TMPRN")=$ORDER(^TMP($JOB,"PSOERR",APSPERR,APSLNM,APSP("TMPRN")))
IF 'APSP("TMPRN")
QUIT
DO APSPGN
+8 DO MSG1
+9 QUIT
APSPGN ;GET DRUG NAME FOR EMAIL MSG
+1 ;SORT BY APSPERR IHS/OKCAO/POC 8/30/2003
+2 ;S APSP("ERR")=$P($G(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN"))),"^",2),APSPDG=APSLNM
+3 ;I APSP("ERR")=3 S APSP("MEDI")=$P(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN")),"^",4),APSP("LOC")=$P(^TMP($J,"PSOERR",APSLNM,APSP("TMPRN")),"^",3)
+4 SET APSP("ERR")=$PIECE($GET(^TMP($JOB,"PSOERR",APSPERR,APSLNM,APSP("TMPRN"))),"^",2)
SET APSPDG=APSLNM
+5 IF APSP("ERR")=3
SET APSP("MEDI")=$PIECE(^TMP($JOB,"PSOERR",APSPERR,APSLNM,APSP("TMPRN")),"^",4)
SET APSP("LOC")=$PIECE(^TMP($JOB,"PSOERR",APSPERR,APSLNM,APSP("TMPRN")),"^",3)
+6 ;GET ERROR CODE
DO ERR
+7 IF APSPZ>200
DO MSG1
DO XMSET
DO TEXT
SET APSPZ=11
+8 QUIT
XMSET ;SET MAIL VARIABLES
+1 ;K XMY S XMSUB="Outpatient Pharmacy AWP Automatic Update",XMDUZ="OUTPATIENT PHARMACY DEVELOPER"
+2 ;IHS/OIT/CLS 11/28/2011 patch 1013
KILL XMY
SET XMSUB="Outpatient Pharmacy Benchmark Price Automatic Update"
SET XMDUZ="OUTPATIENT PHARMACY DEVELOPER"
+3 DO RPH
+4 QUIT
MSG1 DO ^XMD
KILL APSPMSG
+1 QUIT
TEXT ;CHANGED THE WORDING 6/28/2002 IHS/OKCAO/POC
SET APSPMSG(1,0)="A Pricing update was performed on your system on "_APSP("RUN DATE")_"."
SET APSPMSG(2,0)="The total number of records updated = "_APSP("TOTAL REC")
SET APSPMSG(3,0)=""
+1 SET APSPMSG(4,0)="Listed below are the active drugs that were not updated and the error codes."
+2 SET APSPMSG(5,0)="Please review and correct all errors before attempting to run the manual "
+3 ;S APSPMSG(6,0)="AWP update option."
+4 ;IHS/OIT/CLS 11/28/2011 patch 1013
SET APSPMSG(6,0)="Benchmark Price update option."
+5 SET APSPMSG(7,0)="Note: any 'missing 660 node' errors means that information like (ie. Reorder"
+6 SET APSPMSG(8,0)=" Level, Order Unit, Price Per Order Unit, Dispense Units Per"
+7 SET APSPMSG(9,0)=" Order unit, Price Per Dispense Unit, etc) is missing!"
+8 SET APSPMSG(10,0)=" "
+9 SET XMTEXT="APSPMSG("
SET %H=$HOROLOG
DO YX^%DTC
+10 QUIT
RPH ;GET HOLDERS OF 'PSOMCORE' (PHARMACIST)
+1 ;S XMY("MOORE,EDGAR")="" Q ;TEMPORARY, REMOVE AFTER TESTING
+2 SET J=0
+3 FOR J=0:0
SET J=$ORDER(^XUSEC("PSOMCORE",J))
IF 'J
QUIT
SET APSPNAME=$PIECE($GET(^VA(200,J,0)),"^")
SET XMY(APSPNAME)=""
+4 ;F J=0:0 S J=$O(^XUSEC("AZOAWPGLORES",J)) Q:'J S APSPNAME=$P($G(^VA(200,J,0)),"^"),XMY(APSPNAME)="" ;IHS/OKCAO/POC 6/22/98 CHANGE SECURITY KEY
+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 ^TMP($JOB,"PSOERR"),APSLNM,APSP,APSPDG,APSPNAME,APSPZ,XMDUZ,APSA,APSDNAME,APSPERR,APSPIRN,APSPNDC,APSPNDC2,APSPNOD1,APSPNOD2,J,X,XMSUB,XMTEXT
+2 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
MANU ;EP - ENTRY POINT FOR PHARMACIST TO USE AFTER FIXING DRUGS
+1 KILL ^TMP($JOB,"PSOERR")
+2 NEW DIR
+3 SET DIR(0)="Y"
SET DIR("A")="Perform Update"
SET DIR("B")="NO"
DO ^DIR
+4 IF 'Y
QUIT
+5 ;W !,"AWP Update in progress, Please hold on........."
+6 ;IHS/OIT/CLS 11/28/2011 patch 1013
WRITE !,"Benchmark Price Update in progress, Please hold on........."
+7 ;I '$D(^APSAMDF("DATE")) W !,*7,"No Medi-Span database loaded......quitting!!",! H 5 Q
+8 IF '$DATA(^APSAMDF("DATE"))
WRITE !,*7,"No Facts & Comparisons database loaded......quitting!!",!
HANG 5
QUIT
+9 DO P1
+10 DO ZAAP
+11 ;W !,"AWP Update done!! Please check your mail for any error messages",!
+12 ;IHS/OIT/CLS 11/28/2011 patch 2013
WRITE !,"Benchmark Price Update done!! Please check your mail for any error messages",!
+13 QUIT
+14 ; IHS/CIA/PLS - 01/13/04
AUTOQ ;EP - ENTRY POINT FOR AUTO QUEUEING OF APSA AWP AUTO QUEUE OPTION
+1 IF '$$FIND1^DIC(19,"","MX","APSA AWP AUTO QUEUE")
QUIT
+2 IF $$FIND1^DIC(19.2,"","MX","APSA AWP AUTO QUEUE")
Begin DoDot:1
+3 DO EDIT^XUTMOPT("APSA AWP AUTO QUEUE")
End DoDot:1
+4 IF '$TEST
Begin DoDot:1
+5 DO RESCH^XUTMOPT("APSA AWP AUTO QUEUE","","","24H","L")
+6 DO EDIT^XUTMOPT("APSA AWP AUTO QUEUE")
End DoDot:1
+7 QUIT
