PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm
;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246,584**;DEC 1997;Build 3
;External Ref. to ^PS(55 DBIA# 2228
;External Ref. to ^DPT DBIA# 10035
;External Ref. to ^PSDRUG DBIA# 221
;
;*212 don't allow this request, if monthly compile is running
;*246 alter SRCH1 For loop to not init to numeric values
;
Q:$$MTHLCK(1) ;get lock, quit if already locked PSO*212
K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00"
BEG W ! S %DT="APE",%DT("A")=" Beginning MONTH/YEAR : " D ^%DT G:Y<0 Q W:Y'<LATE !!,$C(7),"Run 'DAILY' compilation routine for selected month!",! G:Y'<LATE BEG I (+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) D QUES G BEG
S BDT=Y
END S %DT(0)=BDT W ! S %DT="APE",%DT("A")=" Ending MONTH/YEAR : " D ^%DT K %DT G:Y<0 Q W:Y'<LATE !!,$C(7),"Run 'DAILY' compilation routine for selected month!",! G:Y'<LATE END I (+$E(Y,6,7)'=0)!(+$E(Y,4,5)=0) D QUES G END
W ! S EDT=Y
S ZTIO="",ZTRTN="START^PSOCSTM",ZTDESC="Rx Monthly Cost Compile" F G="EDT","BDT" S:$D(@G) ZTSAVE(G)=""
D ^%ZTLOAD W:$D(ZTSK) !,"Task #"_ZTSK_" Queued!" K G,BDT,EDT,ZTSAVE,ZTIO,ZTRTN,ZTDESC Q
L -^PSOCSTM ;unlock month end flag
;
START Q:$$MTHLCK^PSOCSTM(1) ;get lock, quit if already locked PSO*212
K ^TMP($J) S PSG=0 F I=1:1 S X=$T(G+I) Q:$P(X,";",3)="" S A(I)=$P(X,";",3),B(I)=$P(X,";",4),PSG=PSG+1,A1(I)=$P(X,";",5),B1(I)=$P(X,";",6)
S PSD=0 F I=1:1 S X=$T(D+I) Q:X="" S C(I)=$P(X,";",3),D(I)=$P(X,";",4),PSD=PSD+1,C1(I)=$P(X,";",5),D1(I)=$P(X,";",6)
F PSDT=BDT:100:EDT K ^PSCST(PSDT),^PSCST("B",PSDT)
S STOP=$E(EDT,1,5)_"31.2359",PSDT=BDT F S PSDT=$O(^PSCST(PSDT)) Q:'PSDT!(PSDT>STOP) K ^PSCST(PSDT),^PSCST("B",PSDT)
K STOP
;
SRCH F PSDT=BDT:100:EDT S PSDTX=PSDT+100 D:$E(PSDT,4,5)<13 SRCH1,SET1 S:$E(PSDT,4,5)>12 PSDT=$E(PSDT,1,2)_($E(PSDT,3)+1)_"0000"
S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT S PSD=PSDT,PSOCNT=PSOCNT+1
S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE
Q K ^TMP($J),%DT,A,B,BDT,COST,DATA,DATA1,DATA2,DRG,DFN,EDT,I,II,LATE,ML,OR,PAST,PHYS,PSOCNT,PSD,PSDT,PSDT1,PSDTX,RXF,PSG,QTY,RF,RX0
K RX2,DIV,D,C,CLINIC,A1,B1,C1,D1,RX1,RXN,VAL,VAR,PGM,VALUE,CDT,NDT,VISITS,DV,VIS,WD,X,X1,X2,Y S:$D(ZTQUEUED) ZTREQ="@"
L -^PSOCSTM ;unlock month end flag
Q
;
SRCH1 D INI
;refill
S PSDT1=PSDT ;*246
F S PSDT1=$O(^PSRX("AL",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX) D
.S CDT=$P(PSDT1,".") F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT1,RXN)) Q:'RXN S RXF="" F S RXF=$O(^PSRX("AL",PSDT1,RXN,RXF)) Q:RXF="" D CHK
.S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
;partial fill
S PSDT1=PSDT ;*246
F S PSDT1=$O(^PSRX("AM",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX) D
.S CDT=$P(PSDT1,"."),RXN=0 F S RXN=$O(^PSRX("AM",PSDT1,RXN)) Q:'RXN S RXF=0 F S RXF=$O(^PSRX("AM",PSDT1,RXN,RXF)) Q:RXF="" S PAR=1 D CHK
.S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR
Q
INI K VIS S (VISITS,DV)=0 F S DV=$O(^PS(59,DV)) Q:'+DV S VIS(DV)=0
Q
VST S DV=0 F S DV=$O(^TMP($J,"PAT",DV)) Q:'DV D
.S DFN=0 F S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1
K ^TMP($J,"PAT") Q
CHK I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
Q:'$D(^PSRX(RXN,2)) S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2)
S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0)) D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0))
;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0))
S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0))
S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0))
S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0))
S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC
S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0)
I $G(PAR) D S PR=0 Q
.I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q
.I $P(^PSRX(RXN,"P",RXF,0),"^",19) D
..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4))
..S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) ;p584 S COST=QTY*COST D SET,SF
..S COST=$S(+$P(RX1,"^",11):+$P(RX1,"^",11),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0) S COST=QTY*COST D SET,SF ;p584
I $P(RX2,"^",13),'RXF D Q
.S OR=1,RF=0,QTY=+$P(RX0,"^",7),ML=$S($P(RX0,"^",11)="M":1,1:0),WD=$S($P(RX0,"^",11)="W":1,1:0),COST=QTY*COST D SET,SF
D:RXF
.I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
.Q:'$P(^PSRX(RXN,1,RXF,0),"^",18) S RX1=^PSRX(RXN,1,RXF,0)
.S OR=0,RF=1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) ;p584 S COST=QTY*COST
.S COST=$S(+$P(RX1,"^",11):+$P(RX1,"^",11),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0) S COST=QTY*COST ;p584
.S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
.D SET,SF
Q
SF S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)=""
F I=1:1:PSG Q:('$D(CLINIC))&(I=PSG) S DATA1=$S($D(@A(I))#2:^(0),1:@(B(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D
.F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2
.S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I)
F I=1:1:PSD S DATA1=$S(($D(@(C(I)))#2):$G(^(0)),1:@(D(I))_"^0^0^0^0") S DATA2=+$P(DATA1,"^") D
.F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D
.S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I)
Q
;
SET S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q
SET1 S ^PSCST(PSDT,1)=DT_"^"_VISITS
S DV=0 F S DV=$O(VIS(DV)) Q:'DV S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV)
Q
QUES W !,$C(7),"??",!,"For example, September 1993 could be entered as 9/93 or SEP 93.",!,"For Year 2000 Compliance enter date as 9/2000 or SEP 2000." Q
ZNODE ;update zero nodes
F PSDT=BDT:$S('$D(BEGDATE):100,1:1):EDT S NDZ=0 F ND="D","P","PS","S","V" S NODE(ND)=0 D:$O(^PSCST(PSDT,"D",0))
.F S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V"
..S NDZ1=0,NODE(ND,"P")=0 F S NDZ1=$O(^PSCST(PSDT,ND,NDZ2,"P",NDZ1)) Q:'NDZ1 S NODE(ND,"P")=NODE(ND,"P")+1
..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0
.S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0
K NDZ,ND,NODE,NDZ2,NDZ1 Q
;
MTHLCK(GET) ;lock for month end run or query if month end is running
; INPUT: GET = 1 try to get lock and keep locked
; 0 query if locked only, leave as unlocked
; RETURNS: 1 - already locked
; 0 - was not already locked
;
I '$D(ZTQUEUED) W !,"checking for duplicate job..."
N GOTLOCK
L +^PSOCSTM:10 S GOTLOCK=$T ;delay 10 secs to handle slower systems
I GOTLOCK,'GET L -^PSOCSTM Q 0
I GOTLOCK,GET Q 0
N AST S AST="",$P(AST,"*",79)=""
D:'($D(ZTQUEUED))
.W !!,*7,AST,!
.W "Monthly Rx Cost Compilation is currently running, "
.W "Try your request later",!
.W AST,!!
Q 1
;
;
G ;;
;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1
;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^
;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^
;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^
;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^
;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^
;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^
;;
D ;;
;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^
;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^
;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCSTM 7948 printed Oct 16, 2024@18:26:59 Page 2
PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm
+1 ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246,584**;DEC 1997;Build 3
+2 ;External Ref. to ^PS(55 DBIA# 2228
+3 ;External Ref. to ^DPT DBIA# 10035
+4 ;External Ref. to ^PSDRUG DBIA# 221
+5 ;
+6 ;*212 don't allow this request, if monthly compile is running
+7 ;*246 alter SRCH1 For loop to not init to numeric values
+8 ;
+9 ;get lock, quit if already locked PSO*212
if $$MTHLCK(1)
QUIT
+10 KILL BDT,EDT
WRITE !!,"**** Date Range Selection ****"
SET LATE=$EXTRACT(DT,1,5)_"00"
BEG WRITE !
SET %DT="APE"
SET %DT("A")=" Beginning MONTH/YEAR : "
DO ^%DT
if Y<0
GOTO Q
if Y'<LATE
WRITE !!,$CHAR(7),"Run 'DAILY' compilation routine for selected month!",!
if Y'<LATE
GOTO BEG
IF (+$EXTRACT(Y,6,7)'=0)!(+$EXTRACT(Y,4,5)=0)
DO QUES
GOTO BEG
+1 SET BDT=Y
END SET %DT(0)=BDT
WRITE !
SET %DT="APE"
SET %DT("A")=" Ending MONTH/YEAR : "
DO ^%DT
KILL %DT
if Y<0
GOTO Q
if Y'<LATE
WRITE !!,$CHAR(7),"Run 'DAILY' compilation routine for selected month!",!
if Y'<LATE
GOTO END
IF (+$EXTRACT(Y,6,7)'=0)!(+$EXTRACT(Y,4,5)=0)
DO QUES
GOTO END
+1 WRITE !
SET EDT=Y
+2 SET ZTIO=""
SET ZTRTN="START^PSOCSTM"
SET ZTDESC="Rx Monthly Cost Compile"
FOR G="EDT","BDT"
if $DATA(@G)
SET ZTSAVE(G)=""
+3 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Task #"_ZTSK_" Queued!"
KILL G,BDT,EDT,ZTSAVE,ZTIO,ZTRTN,ZTDESC
QUIT
+4 ;unlock month end flag
LOCK -^PSOCSTM
+5 ;
START ;get lock, quit if already locked PSO*212
if $$MTHLCK^PSOCSTM(1)
QUIT
+1 KILL ^TMP($JOB)
SET PSG=0
FOR I=1:1
SET X=$TEXT(G+I)
if $PIECE(X,";",3)=""
QUIT
SET A(I)=$PIECE(X,";",3)
SET B(I)=$PIECE(X,";",4)
SET PSG=PSG+1
SET A1(I)=$PIECE(X,";",5)
SET B1(I)=$PIECE(X,";",6)
+2 SET PSD=0
FOR I=1:1
SET X=$TEXT(D+I)
if X=""
QUIT
SET C(I)=$PIECE(X,";",3)
SET D(I)=$PIECE(X,";",4)
SET PSD=PSD+1
SET C1(I)=$PIECE(X,";",5)
SET D1(I)=$PIECE(X,";",6)
+3 FOR PSDT=BDT:100:EDT
KILL ^PSCST(PSDT),^PSCST("B",PSDT)
+4 SET STOP=$EXTRACT(EDT,1,5)_"31.2359"
SET PSDT=BDT
FOR
SET PSDT=$ORDER(^PSCST(PSDT))
if 'PSDT!(PSDT>STOP)
QUIT
KILL ^PSCST(PSDT),^PSCST("B",PSDT)
+5 KILL STOP
+6 ;
SRCH FOR PSDT=BDT:100:EDT
SET PSDTX=PSDT+100
if $EXTRACT(PSDT,4,5)<13
DO SRCH1
DO SET1
if $EXTRACT(PSDT,4,5)>12
SET PSDT=$EXTRACT(PSDT,1,2)_($EXTRACT(PSDT,3)+1)_"0000"
+1 SET PSOCNT=0
FOR PSDT=0:0
SET PSDT=$ORDER(^PSCST("B",PSDT))
if 'PSDT
QUIT
SET PSD=PSDT
SET PSOCNT=PSOCNT+1
+2 SET ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT
DO ZNODE
Q KILL ^TMP($JOB),%DT,A,B,BDT,COST,DATA,DATA1,DATA2,DRG,DFN,EDT,I,II,LATE,ML,OR,PAST,PHYS,PSOCNT,PSD,PSDT,PSDT1,PSDTX,RXF,PSG,QTY,RF,RX0
+1 KILL RX2,DIV,D,C,CLINIC,A1,B1,C1,D1,RX1,RXN,VAL,VAR,PGM,VALUE,CDT,NDT,VISITS,DV,VIS,WD,X,X1,X2,Y
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 ;unlock month end flag
LOCK -^PSOCSTM
+3 QUIT
+4 ;
SRCH1 DO INI
+1 ;refill
+2 ;*246
SET PSDT1=PSDT
+3 FOR
SET PSDT1=$ORDER(^PSRX("AL",PSDT1))
if ($EXTRACT(PSDT1,1,7)<PSDT)!($EXTRACT(PSDT1,1,7)>PSDTX)
QUIT
Begin DoDot:1
+4 SET CDT=$PIECE(PSDT1,".")
FOR RXN=0:0
SET RXN=$ORDER(^PSRX("AL",PSDT1,RXN))
if 'RXN
QUIT
SET RXF=""
FOR
SET RXF=$ORDER(^PSRX("AL",PSDT1,RXN,RXF))
if RXF=""
QUIT
DO CHK
+5 SET NDT=$ORDER(^PSRX("AL",PSDT1))
if $PIECE(NDT,".")'=CDT
DO VST
End DoDot:1
+6 ;partial fill
+7 ;*246
SET PSDT1=PSDT
+8 FOR
SET PSDT1=$ORDER(^PSRX("AM",PSDT1))
if ($EXTRACT(PSDT1,1,7)<PSDT)!($EXTRACT(PSDT1,1,7)>PSDTX)
QUIT
Begin DoDot:1
+9 SET CDT=$PIECE(PSDT1,".")
SET RXN=0
FOR
SET RXN=$ORDER(^PSRX("AM",PSDT1,RXN))
if 'RXN
QUIT
SET RXF=0
FOR
SET RXF=$ORDER(^PSRX("AM",PSDT1,RXN,RXF))
if RXF=""
QUIT
SET PAR=1
DO CHK
+10 SET NDT=$ORDER(^PSRX("AM",PSDT1))
if $PIECE(NDT,".")'=CDT
DO VST
KILL PAR
End DoDot:1
+11 QUIT
INI KILL VIS
SET (VISITS,DV)=0
FOR
SET DV=$ORDER(^PS(59,DV))
if '+DV
QUIT
SET VIS(DV)=0
+1 QUIT
VST SET DV=0
FOR
SET DV=$ORDER(^TMP($JOB,"PAT",DV))
if 'DV
QUIT
Begin DoDot:1
+1 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"PAT",DV,DFN))
if 'DFN
QUIT
SET VIS(DV)=VIS(DV)+1
SET VISITS=VISITS+1
End DoDot:1
+2 KILL ^TMP($JOB,"PAT")
QUIT
CHK IF '$DATA(^PSRX(RXN,0))
KILL ^PSRX("AL",PSDT,RXN,RXF)
QUIT
+1 if '$DATA(^PSRX(RXN,2))
QUIT
SET RX0=^PSRX(RXN,0)
SET RX2=^PSRX(RXN,2)
+2 SET DFN=+$PIECE(RX0,"^",2)
if '$DATA(^DPT(DFN,0))
QUIT
if $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
DO EN^PSOHLUP(DFN)
+3 SET DRG=+$PIECE(RX0,"^",6)
if '$DATA(^PSDRUG(DRG,0))
QUIT
+4 ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0))
+5 SET DIV=+$PIECE(RX2,"^",9)
if '$DATA(^PS(59,DIV,0))
QUIT
+6 SET PHYS=+$PIECE(RX0,"^",4)
if '$DATA(^VA(200,PHYS,0))
QUIT
+7 SET PAST=+$PIECE(RX0,"^",3)
if '$DATA(^PS(53,PAST,0))
QUIT
+8 SET CLINIC=+$PIECE(RX0,"^",5)
if '$DATA(^SC(CLINIC,0))
KILL CLINIC
+9 SET COST=$SELECT(+$PIECE(RX0,"^",17):+$PIECE(RX0,"^",17),$DATA(^PSDRUG(DRG,660)):+$PIECE(^(660),"^",6),1:0)
+10 IF $GET(PAR)
Begin DoDot:1
+11 IF '$DATA(^PSRX(RXN,"P",RXF,0))
KILL ^PSRX("AM",PSDT,RXN,RXF)
QUIT
+12 IF $PIECE(^PSRX(RXN,"P",RXF,0),"^",19)
Begin DoDot:2
+13 SET RX1=^PSRX(RXN,"P",RXF,0)
SET DIV=$SELECT($PIECE(RX1,"^",9):$PIECE(RX1,"^",9),1:$PIECE(RX2,"^",9))
+14 SET PHYS=$SELECT($PIECE(RX1,"^",17):$PIECE(RX1,"^",17),1:$PIECE(RX0,"^",4))
+15 ;p584 S COST=QTY*COST D SET,SF
SET OR=0
SET RF=1
SET QTY=+$PIECE(RX1,"^",4)
SET ML=$SELECT($PIECE(RX1,"^",2)="M":1,1:0)
SET WD=$SELECT($PIECE(RX1,"^",2)="W":1,1:0)
+16 ;p584
SET COST=$SELECT(+$PIECE(RX1,"^",11):+$PIECE(RX1,"^",11),$DATA(^PSDRUG(DRG,660)):+$PIECE(^(660),"^",6),1:0)
SET COST=QTY*COST
DO SET
DO SF
End DoDot:2
End DoDot:1
SET PR=0
QUIT
+17 IF $PIECE(RX2,"^",13)
IF 'RXF
Begin DoDot:1
+18 SET OR=1
SET RF=0
SET QTY=+$PIECE(RX0,"^",7)
SET ML=$SELECT($PIECE(RX0,"^",11)="M":1,1:0)
SET WD=$SELECT($PIECE(RX0,"^",11)="W":1,1:0)
SET COST=QTY*COST
DO SET
DO SF
End DoDot:1
QUIT
+19 if RXF
Begin DoDot:1
+20 IF '$DATA(^PSRX(RXN,1,RXF,0))
KILL ^PSRX("AL",PSDT,RXN,RXF)
QUIT
+21 if '$PIECE(^PSRX(RXN,1,RXF,0),"^",18)
QUIT
SET RX1=^PSRX(RXN,1,RXF,0)
+22 ;p584 S COST=QTY*COST
SET OR=0
SET RF=1
SET QTY=+$PIECE(RX1,"^",4)
SET ML=$SELECT($PIECE(RX1,"^",2)="M":1,1:0)
SET WD=$SELECT($PIECE(RX1,"^",2)="W":1,1:0)
+23 ;p584
SET COST=$SELECT(+$PIECE(RX1,"^",11):+$PIECE(RX1,"^",11),$DATA(^PSDRUG(DRG,660)):+$PIECE(^(660),"^",6),1:0)
SET COST=QTY*COST
+24 SET PHYS=$SELECT($PIECE(RX1,"^",17):$PIECE(RX1,"^",17),1:$PIECE(RX0,"^",4))
SET DIV=$SELECT($PIECE(RX1,"^",9):$PIECE(RX1,"^",9),1:$PIECE(RX2,"^",9))
+25 DO SET
DO SF
End DoDot:1
+26 QUIT
SF SET DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD
SET ^TMP($JOB,"PAT",DIV,DFN)=""
+1 FOR I=1:1:PSG
if ('$DATA(CLINIC))&(I=PSG)
QUIT
SET DATA1=$SELECT($DATA(@A(I))#2:^(0),1:@(B(I))_"^0^0^0^0")
SET DATA2=+$PIECE(DATA1,"^")
Begin DoDot:1
+2 FOR II=2:1:7
SET VALUE=$PIECE(DATA,"^",II)+$PIECE(DATA1,"^",II)
SET DATA2=DATA2_"^"_VALUE
if II=7
SET @A(I)=DATA2
+3 if '$DATA(@A1(I))
SET @A1(I)=B1(I)
SET $PIECE(@A1(I),"^",4)=+$PIECE(@A1(I),"^",4)+1
SET $PIECE(@A1(I),"^",3)=@B(I)
End DoDot:1
+4 FOR I=1:1:PSD
SET DATA1=$SELECT(($DATA(@(C(I)))#2):$GET(^(0)),1:@(D(I))_"^0^0^0^0")
SET DATA2=+$PIECE(DATA1,"^")
Begin DoDot:1
+5 FOR II=2:1:7
SET VALUE=$PIECE(DATA,"^",II)+$PIECE(DATA1,"^",II)
SET DATA2=DATA2_"^"_VALUE
if II=7
SET @C(I)=DATA2
Begin DoDot:2
End DoDot:2
+6 if '$DATA(@C1(I))
SET @C1(I)=D1(I)
SET $PIECE(@C1(I),"^",4)=+$PIECE(@C1(I),"^",4)+1
SET $PIECE(@C1(I),"^",3)=@D(I)
End DoDot:1
+7 QUIT
+8 ;
SET if '$DATA(^PSCST(PSDT,0))
SET ^PSCST(PSDT,0)=PSDT
SET ^PSCST("B",PSDT,PSDT)=""
QUIT
SET1 SET ^PSCST(PSDT,1)=DT_"^"_VISITS
+1 SET DV=0
FOR
SET DV=$ORDER(VIS(DV))
if 'DV
QUIT
SET $PIECE(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV)
+2 QUIT
QUES WRITE !,$CHAR(7),"??",!,"For example, September 1993 could be entered as 9/93 or SEP 93.",!,"For Year 2000 Compliance enter date as 9/2000 or SEP 2000."
QUIT
ZNODE ;update zero nodes
+1 FOR PSDT=BDT:$SELECT('$DATA(BEGDATE):100,1:1):EDT
SET NDZ=0
FOR ND="D","P","PS","S","V"
SET NODE(ND)=0
if $ORDER(^PSCST(PSDT,"D",0))
Begin DoDot:1
+2 FOR
SET NDZ=$ORDER(^PSCST(PSDT,ND,NDZ))
if 'NDZ
QUIT
SET NODE(ND)=NODE(ND)+1
SET NDZ2=NDZ
if ND="V"
Begin DoDot:2
+3 SET NDZ1=0
SET NODE(ND,"P")=0
FOR
SET NDZ1=$ORDER(^PSCST(PSDT,ND,NDZ2,"P",NDZ1))
if 'NDZ1
QUIT
SET NODE(ND,"P")=NODE(ND,"P")+1
+4 SET $PIECE(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P")
SET NDZ1=0
End DoDot:2
+5 if $GET(^PSCST(PSDT,ND,0))]""
SET $PIECE(^PSCST(PSDT,ND,0),"^",4)=NODE(ND)
SET NDZ=0
End DoDot:1
+6 KILL NDZ,ND,NODE,NDZ2,NDZ1
QUIT
+7 ;
MTHLCK(GET) ;lock for month end run or query if month end is running
+1 ; INPUT: GET = 1 try to get lock and keep locked
+2 ; 0 query if locked only, leave as unlocked
+3 ; RETURNS: 1 - already locked
+4 ; 0 - was not already locked
+5 ;
+6 IF '$DATA(ZTQUEUED)
WRITE !,"checking for duplicate job..."
+7 NEW GOTLOCK
+8 ;delay 10 secs to handle slower systems
LOCK +^PSOCSTM:10
SET GOTLOCK=$TEST
+9 IF GOTLOCK
IF 'GET
LOCK -^PSOCSTM
QUIT 0
+10 IF GOTLOCK
IF GET
QUIT 0
+11 NEW AST
SET AST=""
SET $PIECE(AST,"*",79)=""
+12 if '($DATA(ZTQUEUED))
Begin DoDot:1
+13 WRITE !!,*7,AST,!
+14 WRITE "Monthly Rx Cost Compilation is currently running, "
+15 WRITE "Try your request later",!
+16 WRITE AST,!!
End DoDot:1
+17 QUIT 1
+18 ;
+19 ;
G ;;
+1 ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1
+2 ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^
+3 ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^
+4 ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^
+5 ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^
+6 ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^
+7 ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^
+8 ;;
D ;;
+1 ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^
+2 ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^
+3 ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^
