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

PSXCOSTU.m

Go to the documentation of this file.
  1. PSXCOSTU ;BIR/BAB,WPB,HTW-Cost Update ; 26 Apr 2000 10:52 AM
  1. ;;2.0;CMOP;**18,19,27**;11 Apr 97
  1. ;Reference to ^PSDRUG( supported by DBIA #2367, #1983
  1. ;
  1. ;This routine will update the CMOP Master Database file with cost data from the drug file. Discrepancies will be reported via mail message.
  1. Q
  1. BLANK S ^XMB(3.9,XMZ,2,MCT,0)="" S MCT=MCT+1
  1. Q
  1. EN ;
  1. W !! S DIR(0)="D^::EX",DIR("A")="Enter Begin Date ",DIR("?")="Enter the beginning date for the report" D ^DIR K DIR,DIR("?")
  1. G:($D(DIRUT))!($D(DIROUT)) EXIT
  1. S BB=Y,BEG=$$FMADD^XLFDT(BB,-1,0,0,0) K Y
  1. EDT W !! S DIR(0)="DO^::EX",DIR("A")="Enter End Date ",DIR("?")="Enter the ending date for the report" D ^DIR K DIR,DIR("?")
  1. I $G(Y)']"" W !! G EN
  1. G:($D(DIRUT))!($D(DIROUT)) EXIT
  1. I Y<BB W !,"End Date must follow Begin Date!" K Y,DIR G EDT
  1. S EE=Y,END=$$FMADD^XLFDT(EE,1,0,0,0) K Y,EE
  1. QUE S ZTRTN="GET^PSXCOSTU",ZTIO="",ZTSAVE("BEG")="",ZTSAVE("END")=""
  1. S ZTDESC="CMOP Cost Update for Master Database",ZTSAVE("DUZ")=""
  1. D ^%ZTLOAD
  1. I $D(ZTSK)[0 W !!,"Job Cancelled"
  1. E W !!,"Job Queued"
  1. G EXIT
  1. ; Called by Taskman to Build Cost Data
  1. GET S (C1,CNT)=1
  1. F S BEG=$O(^PSX(552.4,"AD",BEG)) Q:BEG'>0!(BEG=END) S XX=0 F S XX=$O(^PSX(552.4,"AD",BEG,XX)) Q:XX'>0 S YY=0 F S YY=$O(^PSX(552.4,"AD",BEG,XX,YY)) Q:YY'>0 D
  1. .I $P($G(^PSX(552.4,XX,1,YY,0)),U,2)'=1 Q
  1. .I $P(^PSX(552.4,XX,1,YY,0),U,11)>0 Q
  1. .S IDDRG=$P($G(^PSX(552.4,XX,1,YY,0)),U,4) Q:$G(IDDRG)=""
  1. .S CDT=$P($G(^PSX(552.4,XX,1,YY,0)),U,9) I $G(CDT) S Y=$P(CDT,".") X ^DD("DD") S CDT=Y K Y
  1. .S IEN50=$O(^PSDRUG("AQ1",IDDRG,""))
  1. .I $G(IEN50)']"" S ^TMP($J,"PSX",CNT)=IDDRG_" "_$G(CDT) S CNT=CNT+1 Q
  1. .S COST=$P($G(^PSDRUG(IEN50,660)),U,6)
  1. .S Z1=$P($G(^PSDRUG(IEN50,"ND")),U),Z2=$P($G(^("ND")),U,3)
  1. .I $G(Z1),($G(Z2)) S ZX=$$PROD2^PSNAPIS(Z1,Z2),TRUG=$P($G(ZX),"^")
  1. .I $G(COST)']"" S ^TMP($J,"PSX1",C1)=IDDRG_" "_$G(CDT)_" "_$G(TRUG) S C1=C1+1 Q
  1. .S DA(1)=XX,DA=YY,DIE="^PSX(552.4,"_XX_",1,",DR="10////"_$G(COST) D ^DIE
  1. .K DA(1),DA,COST,IDDRG,IEN50,DIE,DR,Z1,Z2
  1. MSG ;
  1. I '$D(^TMP($J,"PSX")),('$D(^TMP($J,"PSX1"))) G EXIT
  1. S XMSUB="CMOP COST UPDATE",XMDUZ=.5
  1. XMZ D XMZ^XMA2
  1. I XMZ'>0 G XMZ
  1. S MCT=2
  1. D NOW^%DTC S Y=% X ^DD("DD")
  1. S ^XMB(3.9,XMZ,2,1,0)="CMOP Master Database Drug Cost Update "_Y K Y
  1. F I=1:1:2 D BLANK
  1. I '$D(^TMP($J,"PSX")) G PSX1
  1. S ^XMB(3.9,XMZ,2,MCT,0)="The drug ID's listed below are missing a corresponding entry in Drug file 50, therefore, no cost information can be updated for any prescription written"
  1. S MCT=MCT+1
  1. S ^XMB(3.9,XMZ,2,MCT,0)="for this drug. When the drug file entry is available, the Cost Update option may be re-run for the dates indicated to enter the costs for these drugs."
  1. S MCT=MCT+1
  1. D BLANK
  1. S ^XMB(3.9,XMZ,2,MCT,0)="DRUG ID COMPLETED D/T"
  1. S MCT=MCT+1
  1. D BLANK
  1. F I=0:0 S I=$O(^TMP($J,"PSX",I)) Q:'I D
  1. .S ^XMB(3.9,XMZ,2,MCT,0)=^TMP($J,"PSX",I) S MCT=MCT+1
  1. F I=1:1:2 D BLANK
  1. PSX1 I '$D(^TMP($J,"PSX1")) G MSGEND
  1. S ^XMB(3.9,XMZ,2,MCT,0)="The Drug File entries listed below do not contain cost data so prescriptions for these drugs have not been updated. When the cost data is entered, "
  1. S MCT=MCT+1
  1. S ^XMB(3.9,XMZ,2,MCT,0)="the Cost Update option may be re-run to update the prescription entries."
  1. S MCT=MCT+1
  1. D BLANK
  1. S ^XMB(3.9,XMZ,2,MCT,0)="DRUG ID COMPLETED D/T DRUG NAME"
  1. S MCT=MCT+1
  1. D BLANK
  1. F I=0:0 S I=$O(^TMP($J,"PSX1",I)) Q:'I D
  1. .S ^XMB(3.9,XMZ,2,MCT,0)=^TMP($J,"PSX1",I) S MCT=MCT+1
  1. MSGEND S ^XMB(3.9,XMZ,2,0)="^3.92A^"_MCT_U_MCT_U_DT,XMDUN="CMOP Manager"
  1. S XMDUZ=.5,XMY(DUZ)=""
  1. D ENT1^XMD
  1. EXIT K ID,XX,YY,BEG,END,IDDRG,IEN50,CNT,COST,^TMP($J),CDT,BB
  1. K XMSER,XQMSG,XMZ,XMSUB S ZTREQ="@"
  1. Q