- 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 Feb 18, 2025@23:52:47 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^^