Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSAWP2

APSAWP2.m

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