PSXCOSTU ;BIR/BAB,WPB,HTW-Cost Update ; 26 Apr 2000 10:52 AM
;;2.0;CMOP;**18,19,27**;11 Apr 97
;Reference to ^PSDRUG( supported by DBIA #2367, #1983
;
;This routine will update the CMOP Master Database file with cost data from the drug file. Discrepancies will be reported via mail message.
Q
BLANK S ^XMB(3.9,XMZ,2,MCT,0)="" S MCT=MCT+1
Q
EN ;
W !! S DIR(0)="D^::EX",DIR("A")="Enter Begin Date ",DIR("?")="Enter the beginning date for the report" D ^DIR K DIR,DIR("?")
G:($D(DIRUT))!($D(DIROUT)) EXIT
S BB=Y,BEG=$$FMADD^XLFDT(BB,-1,0,0,0) K Y
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("?")
I $G(Y)']"" W !! G EN
G:($D(DIRUT))!($D(DIROUT)) EXIT
I Y<BB W !,"End Date must follow Begin Date!" K Y,DIR G EDT
S EE=Y,END=$$FMADD^XLFDT(EE,1,0,0,0) K Y,EE
QUE S ZTRTN="GET^PSXCOSTU",ZTIO="",ZTSAVE("BEG")="",ZTSAVE("END")=""
S ZTDESC="CMOP Cost Update for Master Database",ZTSAVE("DUZ")=""
D ^%ZTLOAD
I $D(ZTSK)[0 W !!,"Job Cancelled"
E W !!,"Job Queued"
G EXIT
; Called by Taskman to Build Cost Data
GET S (C1,CNT)=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
.I $P($G(^PSX(552.4,XX,1,YY,0)),U,2)'=1 Q
.I $P(^PSX(552.4,XX,1,YY,0),U,11)>0 Q
.S IDDRG=$P($G(^PSX(552.4,XX,1,YY,0)),U,4) Q:$G(IDDRG)=""
.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
.S IEN50=$O(^PSDRUG("AQ1",IDDRG,""))
.I $G(IEN50)']"" S ^TMP($J,"PSX",CNT)=IDDRG_" "_$G(CDT) S CNT=CNT+1 Q
.S COST=$P($G(^PSDRUG(IEN50,660)),U,6)
.S Z1=$P($G(^PSDRUG(IEN50,"ND")),U),Z2=$P($G(^("ND")),U,3)
.I $G(Z1),($G(Z2)) S ZX=$$PROD2^PSNAPIS(Z1,Z2),TRUG=$P($G(ZX),"^")
.I $G(COST)']"" S ^TMP($J,"PSX1",C1)=IDDRG_" "_$G(CDT)_" "_$G(TRUG) S C1=C1+1 Q
.S DA(1)=XX,DA=YY,DIE="^PSX(552.4,"_XX_",1,",DR="10////"_$G(COST) D ^DIE
.K DA(1),DA,COST,IDDRG,IEN50,DIE,DR,Z1,Z2
MSG ;
I '$D(^TMP($J,"PSX")),('$D(^TMP($J,"PSX1"))) G EXIT
S XMSUB="CMOP COST UPDATE",XMDUZ=.5
XMZ D XMZ^XMA2
I XMZ'>0 G XMZ
S MCT=2
D NOW^%DTC S Y=% X ^DD("DD")
S ^XMB(3.9,XMZ,2,1,0)="CMOP Master Database Drug Cost Update "_Y K Y
F I=1:1:2 D BLANK
I '$D(^TMP($J,"PSX")) G PSX1
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"
S MCT=MCT+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."
S MCT=MCT+1
D BLANK
S ^XMB(3.9,XMZ,2,MCT,0)="DRUG ID COMPLETED D/T"
S MCT=MCT+1
D BLANK
F I=0:0 S I=$O(^TMP($J,"PSX",I)) Q:'I D
.S ^XMB(3.9,XMZ,2,MCT,0)=^TMP($J,"PSX",I) S MCT=MCT+1
F I=1:1:2 D BLANK
PSX1 I '$D(^TMP($J,"PSX1")) G MSGEND
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, "
S MCT=MCT+1
S ^XMB(3.9,XMZ,2,MCT,0)="the Cost Update option may be re-run to update the prescription entries."
S MCT=MCT+1
D BLANK
S ^XMB(3.9,XMZ,2,MCT,0)="DRUG ID COMPLETED D/T DRUG NAME"
S MCT=MCT+1
D BLANK
F I=0:0 S I=$O(^TMP($J,"PSX1",I)) Q:'I D
.S ^XMB(3.9,XMZ,2,MCT,0)=^TMP($J,"PSX1",I) S MCT=MCT+1
MSGEND S ^XMB(3.9,XMZ,2,0)="^3.92A^"_MCT_U_MCT_U_DT,XMDUN="CMOP Manager"
S XMDUZ=.5,XMY(DUZ)=""
D ENT1^XMD
EXIT K ID,XX,YY,BEG,END,IDDRG,IEN50,CNT,COST,^TMP($J),CDT,BB
K XMSER,XQMSG,XMZ,XMSUB S ZTREQ="@"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXCOSTU 3687 printed Sep 23, 2025@19:19:39 Page 2
PSXCOSTU ;BIR/BAB,WPB,HTW-Cost Update ; 26 Apr 2000 10:52 AM
+1 ;;2.0;CMOP;**18,19,27**;11 Apr 97
+2 ;Reference to ^PSDRUG( supported by DBIA #2367, #1983
+3 ;
+4 ;This routine will update the CMOP Master Database file with cost data from the drug file. Discrepancies will be reported via mail message.
+5 QUIT
BLANK SET ^XMB(3.9,XMZ,2,MCT,0)=""
SET MCT=MCT+1
+1 QUIT
EN ;
+1 WRITE !!
SET DIR(0)="D^::EX"
SET DIR("A")="Enter Begin Date "
SET DIR("?")="Enter the beginning date for the report"
DO ^DIR
KILL DIR,DIR("?")
+2 if ($DATA(DIRUT))!($DATA(DIROUT))
GOTO EXIT
+3 SET BB=Y
SET BEG=$$FMADD^XLFDT(BB,-1,0,0,0)
KILL Y
EDT WRITE !!
SET DIR(0)="DO^::EX"
SET DIR("A")="Enter End Date "
SET DIR("?")="Enter the ending date for the report"
DO ^DIR
KILL DIR,DIR("?")
+1 IF $GET(Y)']""
WRITE !!
GOTO EN
+2 if ($DATA(DIRUT))!($DATA(DIROUT))
GOTO EXIT
+3 IF Y<BB
WRITE !,"End Date must follow Begin Date!"
KILL Y,DIR
GOTO EDT
+4 SET EE=Y
SET END=$$FMADD^XLFDT(EE,1,0,0,0)
KILL Y,EE
QUE SET ZTRTN="GET^PSXCOSTU"
SET ZTIO=""
SET ZTSAVE("BEG")=""
SET ZTSAVE("END")=""
+1 SET ZTDESC="CMOP Cost Update for Master Database"
SET ZTSAVE("DUZ")=""
+2 DO ^%ZTLOAD
+3 IF $DATA(ZTSK)[0
WRITE !!,"Job Cancelled"
+4 IF '$TEST
WRITE !!,"Job Queued"
+5 GOTO EXIT
+6 ; Called by Taskman to Build Cost Data
GET SET (C1,CNT)=1
+1 FOR
SET BEG=$ORDER(^PSX(552.4,"AD",BEG))
if BEG'>0!(BEG=END)
QUIT
SET XX=0
FOR
SET XX=$ORDER(^PSX(552.4,"AD",BEG,XX))
if XX'>0
QUIT
SET YY=0
FOR
SET YY=$ORDER(^PSX(552.4,"AD",BEG,XX,YY))
if YY'>0
QUIT
Begin DoDot:1
+2 IF $PIECE($GET(^PSX(552.4,XX,1,YY,0)),U,2)'=1
QUIT
+3 IF $PIECE(^PSX(552.4,XX,1,YY,0),U,11)>0
QUIT
+4 SET IDDRG=$PIECE($GET(^PSX(552.4,XX,1,YY,0)),U,4)
if $GET(IDDRG)=""
QUIT
+5 SET CDT=$PIECE($GET(^PSX(552.4,XX,1,YY,0)),U,9)
IF $GET(CDT)
SET Y=$PIECE(CDT,".")
XECUTE ^DD("DD")
SET CDT=Y
KILL Y
+6 SET IEN50=$ORDER(^PSDRUG("AQ1",IDDRG,""))
+7 IF $GET(IEN50)']""
SET ^TMP($JOB,"PSX",CNT)=IDDRG_" "_$GET(CDT)
SET CNT=CNT+1
QUIT
+8 SET COST=$PIECE($GET(^PSDRUG(IEN50,660)),U,6)
+9 SET Z1=$PIECE($GET(^PSDRUG(IEN50,"ND")),U)
SET Z2=$PIECE($GET(^("ND")),U,3)
+10 IF $GET(Z1)
IF ($GET(Z2))
SET ZX=$$PROD2^PSNAPIS(Z1,Z2)
SET TRUG=$PIECE($GET(ZX),"^")
+11 IF $GET(COST)']""
SET ^TMP($JOB,"PSX1",C1)=IDDRG_" "_$GET(CDT)_" "_$GET(TRUG)
SET C1=C1+1
QUIT
+12 SET DA(1)=XX
SET DA=YY
SET DIE="^PSX(552.4,"_XX_",1,"
SET DR="10////"_$GET(COST)
DO ^DIE
+13 KILL DA(1),DA,COST,IDDRG,IEN50,DIE,DR,Z1,Z2
End DoDot:1
MSG ;
+1 IF '$DATA(^TMP($JOB,"PSX"))
IF ('$DATA(^TMP($JOB,"PSX1")))
GOTO EXIT
+2 SET XMSUB="CMOP COST UPDATE"
SET XMDUZ=.5
XMZ DO XMZ^XMA2
+1 IF XMZ'>0
GOTO XMZ
+2 SET MCT=2
+3 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
+4 SET ^XMB(3.9,XMZ,2,1,0)="CMOP Master Database Drug Cost Update "_Y
KILL Y
+5 FOR I=1:1:2
DO BLANK
+6 IF '$DATA(^TMP($JOB,"PSX"))
GOTO PSX1
+7 SET ^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"
+8 SET MCT=MCT+1
+9 SET ^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."
+10 SET MCT=MCT+1
+11 DO BLANK
+12 SET ^XMB(3.9,XMZ,2,MCT,0)="DRUG ID COMPLETED D/T"
+13 SET MCT=MCT+1
+14 DO BLANK
+15 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"PSX",I))
if 'I
QUIT
Begin DoDot:1
+16 SET ^XMB(3.9,XMZ,2,MCT,0)=^TMP($JOB,"PSX",I)
SET MCT=MCT+1
End DoDot:1
+17 FOR I=1:1:2
DO BLANK
PSX1 IF '$DATA(^TMP($JOB,"PSX1"))
GOTO MSGEND
+1 SET ^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, "
+2 SET MCT=MCT+1
+3 SET ^XMB(3.9,XMZ,2,MCT,0)="the Cost Update option may be re-run to update the prescription entries."
+4 SET MCT=MCT+1
+5 DO BLANK
+6 SET ^XMB(3.9,XMZ,2,MCT,0)="DRUG ID COMPLETED D/T DRUG NAME"
+7 SET MCT=MCT+1
+8 DO BLANK
+9 FOR I=0:0
SET I=$ORDER(^TMP($JOB,"PSX1",I))
if 'I
QUIT
Begin DoDot:1
+10 SET ^XMB(3.9,XMZ,2,MCT,0)=^TMP($JOB,"PSX1",I)
SET MCT=MCT+1
End DoDot:1
MSGEND SET ^XMB(3.9,XMZ,2,0)="^3.92A^"_MCT_U_MCT_U_DT
SET XMDUN="CMOP Manager"
+1 SET XMDUZ=.5
SET XMY(DUZ)=""
+2 DO ENT1^XMD
EXIT KILL ID,XX,YY,BEG,END,IDDRG,IEN50,CNT,COST,^TMP($JOB),CDT,BB
+1 KILL XMSER,XQMSG,XMZ,XMSUB
SET ZTREQ="@"
+2 QUIT
