- PSOCSTD ;BHAM ISC/SAB - daily rx cost compilation ;9/14/05 1:13pm
- ;;7.0;OUTPATIENT PHARMACY;**4,17,28,89,198,212**;DEC 1997
- ;External Ref to ^DPT DBIA# 10035
- ;External Ref to ^PS(55 DBIA# 2228
- ;External Ref to ^PSDRUG DBIA# 221
- ;
- ;PSO*198 correct For loops to begin on the previous day @ time 999999
- ;PSO*212 quit if it is the 1st day & monthly compile is running
- ;
- I $E(DT,6,7)="01",$$MTHLCK^PSOCSTM(0) Q ;PSO*212
- K BEGDATE,ENDDATE S %DT(0)=$E(DT,1,5)_"00"
- W !!,"**** Date Range Selection ****" I '$O(^PS(59,0)) W $C(7),!,"PLEASE ENTER SITE PARAMETERS !!",!,$C(7) G EX
- BEG W ! S %DT="APE",%DT("A")=" Beginning DATE : " D ^%DT G:"^"[X EX G:Y<0 BEG S (%DT(0),BEGDATE)=Y
- EN W ! S %DT="APE",%DT("A")=" Ending DATE : " D ^%DT K %DT G:"^"[X EX G:Y<0 EN W ! S ENDDATE=Y
- S ZTIO="",ZTRTN="START^PSOCSTD",ZTDESC="Rx Daily Cost Compile" F G="BEGDATE","ENDDATE" S:$D(@G) ZTSAVE(G)=""
- D ^%ZTLOAD W:$D(ZTSK) !,"Task #"_ZTSK_" Queued !" K G,BEGDATE,ENDDATE,ZTSAVE,ZTIO,ZTSK,ZTRTN,ZTDESC Q
- START K ^TMP($J) G:$E(DT,6,7)="01" MTH
- I '$D(BEGDATE)!('$D(ENDDATE)) S X1=DT,X2=-1 D C^%DTC S (BEGDATE,ENDDATE)=X
- K BDT S PSG=0 F I=1:1 S X=$T(G+I) Q:$P(X,";",3)="" S PSOA(I)=$P(X,";",3),PSOB(I)=$P(X,";",4),PSG=PSG+1,PSOA1(I)=$P(X,";",5),PSOB1(I)=$P(X,";",6)
- S PSD=0 F I=1:1 S X=$T(D+I) Q:X="" S PSOC(I)=$P(X,";",3),PSOD(I)=$P(X,";",4),PSD=PSD+1,PSOC1(I)=$P(X,";",5),PSOD1(I)=$P(X,";",6)
- F PSDT=BEGDATE:1:ENDDATE K ^PSCST(PSDT),^PSCST("B",PSDT)
- S (TNR,TNO,TNP)=0
- ;PSO*198 fix begin value of $O loops
- SRCH S PSDT=BEGDATE-1+.999999 F S PSDT=$O(^PSRX("AL",PSDT)) Q:'PSDT!($E(PSDT,1,7)>ENDDATE) S (OR,RF)=0 D SRCH1 S:'$D(BDT) BDT=PSDT
- S PSDT=BEGDATE-1+.999999 F S PSDT=$O(^PSRX("AM",PSDT)) Q:'PSDT!($E(PSDT,1,7)>ENDDATE) D SRCH2 S:'$D(BDT) BDT=PSDT
- 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,EDT=ENDDATE
- F PSDT=BEGDATE:1:ENDDATE F II=2:1:7 S:$D(^PSCST(PSDT,0)) $P(^PSCST(PSDT,0),"^",II)=0
- S PSDT=BEGDATE-1 F S PSDT=$O(^PSCST(PSDT)) Q:'PSDT!(PSDT>ENDDATE) D
- .S DRG=0 F S DRG=$O(^PSCST(PSDT,"D",DRG)) Q:'DRG S DRC=^PSCST(PSDT,"D",DRG,0) D
- ..F II=2:1:7 S $P(^PSCST(PSDT,0),"^",II)=$P(^PSCST(PSDT,0),"^",II)+$P(DRC,"^",II)
- S PSDT=0 F S PSDT=$O(^TMP($J,"PAT",PSDT)) Q:'PSDT D SDFN
- D:$D(BDT) ZNODE^PSOCSTM
- EX K ^TMP($J),FL,%DT,A,B,BEGDATE,COST,DATA,DATA1,DATA2,DRUG,DFN,ENDDATE,I,II,ML,OR,PAST,PHYS,PSOCNT,DIV,PSD,PSDT,PSFILL,PSG,QTY,RF,RX0
- K RXF,PAR,NDZ1,NDZ2,BDT,D,CLINIC,RX1,RX2,RXN,C,VALUE,VISITS,WD,X,X1,X2,Y,BDT,EDT,PSOA1,PSOB1,PSOC1,PSOD1,PSOC
- K TDFN,TDIV S:$D(ZTQUEUED) ZTREQ="@"
- L -^PSOCSTM ;PSO*212
- Q
- SDFN S (TDFN,DIV)=0 F S DIV=$O(^TMP($J,"PAT",PSDT,DIV)) Q:'DIV D SDFN1
- S ^PSCST(PSDT,1)=DT_"^"_TDFN Q
- SDFN1 S (DFN,TDIV)=0 F S DFN=$O(^TMP($J,"PAT",PSDT,DIV,DFN)) Q:'DFN S TDIV=TDIV+1,TDFN=TDFN+1
- S $P(^PSCST(PSDT,"V",DIV,0),"^",8)=TDIV Q
- SRCH1 S RXF="" F RXN=0:0 S RXN=$O(^PSRX("AL",PSDT,RXN)) Q:'RXN F S RXF=$O(^PSRX("AL",PSDT,RXN,RXF)) Q:RXF="" S PAR=0 D CHK S (OR,RF)=0
- Q
- SRCH2 S (RXN,RXF)=0 F S RXN=$O(^PSRX("AM",PSDT,RXN)) Q:'RXN F S RXF=$O(^PSRX("AM",PSDT,RXN,RXF)) Q:'RXF S PAR=1 D CHK S (OR,RF)=0
- Q
- CHK Q:'$D(^PSRX(RXN,0)) I '$D(^PSRX(RXN,2)) Q
- S RX0=^PSRX(RXN,0) S 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 DRUG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRUG,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(DRUG,660)):+$P(^(660),"^",6),1:0)
- S QTY=+$P(RX0,"^",7),ML=$S($P(RX0,"^",11)="M":1,1:0),WD=$S($P(RX0,"^",11)="W":1,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) S RF=0,RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9)) D SET,REF S TNP=TNP+1
- I $P(RX2,"^",13),'RXF S OR=OR+1,COST=QTY*COST D SET,SF S TNO=TNO+1 Q
- D:RXF
- .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
- .I $P(^PSRX(RXN,1,RXF,0),"^",18) S RF=0,RX1=^PSRX(RXN,1,RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9)) D SET,REF S TNR=TNR+1
- Q
- SF S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD
- S:'$D(^TMP($J,"PAT",$P(PSDT,"."),DIV,DFN)) ^TMP($J,"PAT",$P(PSDT,"."),DIV,DFN)=""
- F I=1:1:PSG Q:('$D(CLINIC))&(I=PSG) S DATA1=$S(($D(@(PSOA(I)))#2):^(0),1:@(PSOB(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 @PSOA(I)=DATA2
- .S:'$D(@PSOA1(I)) @PSOA1(I)=PSOB1(I) S $P(@PSOA1(I),"^",4)=+$P(@PSOA1(I),"^",4)+1,$P(@PSOA1(I),"^",3)=@PSOB(I)
- F I=1:1:PSD S DATA1=$S(($D(@(PSOC(I)))#2):$G(^(0)),1:@(PSOD(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 @PSOC(I)=DATA2 D
- .S:'$D(@PSOC1(I)) @PSOC1(I)=PSOD1(I) S $P(@PSOC1(I),"^",4)=+$P(@PSOC1(I),"^",4)+1,$P(@PSOC1(I),"^",3)=@PSOD(I)
- Q
- SET S ^PSCST($P(PSDT,"."),0)=$P(PSDT,"."),^PSCST("B",$P(PSDT,"."),$P(PSDT,"."))="" Q
- ;
- MTH S X1=DT,X2=-1 D C^%DTC S (BDT,EDT)=$E(X,1,5)_"00"
- F PSDT=(BDT+1):1:X K ^PSCST(PSDT),^PSCST("B",PSDT)
- D START^PSOCSTM G EX
- Q
- REF S OR=0,COST=$S(+$P(RX1,"^",11):+$P(RX1,"^",11),$D(^PSDRUG(DRUG,660)):+$P(^(660),"^",6),1:0)
- S RF=RF+1,QTY=+$P(RX1,"^",4),ML=$S($P(RX1,"^",2)="M":1,1:0),WD=$S($P(RX1,"^",2)="W":1,1:0) S COST=QTY*COST
- S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4)) D SF
- Q
- ;
- G ;;
- ;;^PSCST($P(PSDT,"."),0);PSDT;^TMP($J,"A1");1
- ;;^PSCST($P(PSDT,"."),"P",PHYS,0);PHYS;^PSCST($P(PSDT,"."),"P",0);^50.9001PA^^
- ;;^PSCST($P(PSDT,"."),"P",PHYS,"D",DRUG,0);DRUG;^PSCST($P(PSDT,"."),"P",PHYS,"D",0);^50.9002PA^^
- ;;^PSCST($P(PSDT,"."),"D",DRUG,0);DRUG;^PSCST($P(PSDT,"."),"D",0);^50.9003PA^^
- ;;^PSCST($P(PSDT,"."),"D",DRUG,"P",PHYS,0);PHYS;^PSCST($P(PSDT,"."),"D",DRUG,"P",0);^50.9004PA^^
- ;;^PSCST($P(PSDT,"."),"PS",PAST,0);PAST;^PSCST($P(PSDT,"."),"PS",0);^50.9005PA^^
- ;;^PSCST($P(PSDT,"."),"S",CLINIC,0);CLINIC;^PSCST($P(PSDT,"."),"S",0);^50.9008PA^^
- ;;
- D ;;
- ;;^PSCST($P(PSDT,"."),"V",DIV,0);DIV;^PSCST($P(PSDT,"."),"V",0);^50.9006PA^^
- ;;^PSCST($P(PSDT,"."),"V",DIV,"D",DRUG,0);DRUG;^PSCST($P(PSDT,"."),"V",DIV,"D",0);^50.9007PA^^
- ;;^PSCST($P(PSDT,"."),"V",DIV,"P",PHYS,0);PHYS;^PSCST($P(PSDT,"."),"V",DIV,"P",0);^50.901PA^^
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCSTD 6574 printed Feb 18, 2025@23:52:46 Page 2
- PSOCSTD ;BHAM ISC/SAB - daily rx cost compilation ;9/14/05 1:13pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**4,17,28,89,198,212**;DEC 1997
- +2 ;External Ref to ^DPT DBIA# 10035
- +3 ;External Ref to ^PS(55 DBIA# 2228
- +4 ;External Ref to ^PSDRUG DBIA# 221
- +5 ;
- +6 ;PSO*198 correct For loops to begin on the previous day @ time 999999
- +7 ;PSO*212 quit if it is the 1st day & monthly compile is running
- +8 ;
- +9 ;PSO*212
- IF $EXTRACT(DT,6,7)="01"
- IF $$MTHLCK^PSOCSTM(0)
- QUIT
- +10 KILL BEGDATE,ENDDATE
- SET %DT(0)=$EXTRACT(DT,1,5)_"00"
- +11 WRITE !!,"**** Date Range Selection ****"
- IF '$ORDER(^PS(59,0))
- WRITE $CHAR(7),!,"PLEASE ENTER SITE PARAMETERS !!",!,$CHAR(7)
- GOTO EX
- BEG WRITE !
- SET %DT="APE"
- SET %DT("A")=" Beginning DATE : "
- DO ^%DT
- if "^"[X
- GOTO EX
- if Y<0
- GOTO BEG
- SET (%DT(0),BEGDATE)=Y
- EN WRITE !
- SET %DT="APE"
- SET %DT("A")=" Ending DATE : "
- DO ^%DT
- KILL %DT
- if "^"[X
- GOTO EX
- if Y<0
- GOTO EN
- WRITE !
- SET ENDDATE=Y
- +1 SET ZTIO=""
- SET ZTRTN="START^PSOCSTD"
- SET ZTDESC="Rx Daily Cost Compile"
- FOR G="BEGDATE","ENDDATE"
- if $DATA(@G)
- SET ZTSAVE(G)=""
- +2 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"Task #"_ZTSK_" Queued !"
- KILL G,BEGDATE,ENDDATE,ZTSAVE,ZTIO,ZTSK,ZTRTN,ZTDESC
- QUIT
- START KILL ^TMP($JOB)
- if $EXTRACT(DT,6,7)="01"
- GOTO MTH
- +1 IF '$DATA(BEGDATE)!('$DATA(ENDDATE))
- SET X1=DT
- SET X2=-1
- DO C^%DTC
- SET (BEGDATE,ENDDATE)=X
- +2 KILL BDT
- SET PSG=0
- FOR I=1:1
- SET X=$TEXT(G+I)
- if $PIECE(X,";",3)=""
- QUIT
- SET PSOA(I)=$PIECE(X,";",3)
- SET PSOB(I)=$PIECE(X,";",4)
- SET PSG=PSG+1
- SET PSOA1(I)=$PIECE(X,";",5)
- SET PSOB1(I)=$PIECE(X,";",6)
- +3 SET PSD=0
- FOR I=1:1
- SET X=$TEXT(D+I)
- if X=""
- QUIT
- SET PSOC(I)=$PIECE(X,";",3)
- SET PSOD(I)=$PIECE(X,";",4)
- SET PSD=PSD+1
- SET PSOC1(I)=$PIECE(X,";",5)
- SET PSOD1(I)=$PIECE(X,";",6)
- +4 FOR PSDT=BEGDATE:1:ENDDATE
- KILL ^PSCST(PSDT),^PSCST("B",PSDT)
- +5 SET (TNR,TNO,TNP)=0
- +6 ;PSO*198 fix begin value of $O loops
- SRCH SET PSDT=BEGDATE-1+.999999
- FOR
- SET PSDT=$ORDER(^PSRX("AL",PSDT))
- if 'PSDT!($EXTRACT(PSDT,1,7)>ENDDATE)
- QUIT
- SET (OR,RF)=0
- DO SRCH1
- if '$DATA(BDT)
- SET BDT=PSDT
- +1 SET PSDT=BEGDATE-1+.999999
- FOR
- SET PSDT=$ORDER(^PSRX("AM",PSDT))
- if 'PSDT!($EXTRACT(PSDT,1,7)>ENDDATE)
- QUIT
- DO SRCH2
- if '$DATA(BDT)
- SET BDT=PSDT
- +2 SET PSOCNT=0
- FOR PSDT=0:0
- SET PSDT=$ORDER(^PSCST("B",PSDT))
- if 'PSDT
- QUIT
- SET PSD=PSDT
- SET PSOCNT=PSOCNT+1
- +3 SET ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT
- SET EDT=ENDDATE
- +4 FOR PSDT=BEGDATE:1:ENDDATE
- FOR II=2:1:7
- if $DATA(^PSCST(PSDT,0))
- SET $PIECE(^PSCST(PSDT,0),"^",II)=0
- +5 SET PSDT=BEGDATE-1
- FOR
- SET PSDT=$ORDER(^PSCST(PSDT))
- if 'PSDT!(PSDT>ENDDATE)
- QUIT
- Begin DoDot:1
- +6 SET DRG=0
- FOR
- SET DRG=$ORDER(^PSCST(PSDT,"D",DRG))
- if 'DRG
- QUIT
- SET DRC=^PSCST(PSDT,"D",DRG,0)
- Begin DoDot:2
- +7 FOR II=2:1:7
- SET $PIECE(^PSCST(PSDT,0),"^",II)=$PIECE(^PSCST(PSDT,0),"^",II)+$PIECE(DRC,"^",II)
- End DoDot:2
- End DoDot:1
- +8 SET PSDT=0
- FOR
- SET PSDT=$ORDER(^TMP($JOB,"PAT",PSDT))
- if 'PSDT
- QUIT
- DO SDFN
- +9 if $DATA(BDT)
- DO ZNODE^PSOCSTM
- EX KILL ^TMP($JOB),FL,%DT,A,B,BEGDATE,COST,DATA,DATA1,DATA2,DRUG,DFN,ENDDATE,I,II,ML,OR,PAST,PHYS,PSOCNT,DIV,PSD,PSDT,PSFILL,PSG,QTY,RF,RX0
- +1 KILL RXF,PAR,NDZ1,NDZ2,BDT,D,CLINIC,RX1,RX2,RXN,C,VALUE,VISITS,WD,X,X1,X2,Y,BDT,EDT,PSOA1,PSOB1,PSOC1,PSOD1,PSOC
- +2 KILL TDFN,TDIV
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +3 ;PSO*212
- LOCK -^PSOCSTM
- +4 QUIT
- SDFN SET (TDFN,DIV)=0
- FOR
- SET DIV=$ORDER(^TMP($JOB,"PAT",PSDT,DIV))
- if 'DIV
- QUIT
- DO SDFN1
- +1 SET ^PSCST(PSDT,1)=DT_"^"_TDFN
- QUIT
- SDFN1 SET (DFN,TDIV)=0
- FOR
- SET DFN=$ORDER(^TMP($JOB,"PAT",PSDT,DIV,DFN))
- if 'DFN
- QUIT
- SET TDIV=TDIV+1
- SET TDFN=TDFN+1
- +1 SET $PIECE(^PSCST(PSDT,"V",DIV,0),"^",8)=TDIV
- QUIT
- SRCH1 SET RXF=""
- FOR RXN=0:0
- SET RXN=$ORDER(^PSRX("AL",PSDT,RXN))
- if 'RXN
- QUIT
- FOR
- SET RXF=$ORDER(^PSRX("AL",PSDT,RXN,RXF))
- if RXF=""
- QUIT
- SET PAR=0
- DO CHK
- SET (OR,RF)=0
- +1 QUIT
- SRCH2 SET (RXN,RXF)=0
- FOR
- SET RXN=$ORDER(^PSRX("AM",PSDT,RXN))
- if 'RXN
- QUIT
- FOR
- SET RXF=$ORDER(^PSRX("AM",PSDT,RXN,RXF))
- if 'RXF
- QUIT
- SET PAR=1
- DO CHK
- SET (OR,RF)=0
- +1 QUIT
- CHK if '$DATA(^PSRX(RXN,0))
- QUIT
- IF '$DATA(^PSRX(RXN,2))
- QUIT
- +1 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 DRUG=+$PIECE(RX0,"^",6)
- if '$DATA(^PSDRUG(DRUG,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
- SET PAST=+$PIECE(RX0,"^",3)
- if '$DATA(^PS(53,PAST,0))
- QUIT
- +7 SET CLINIC=+$PIECE(RX0,"^",5)
- if '$DATA(^SC(CLINIC,0))
- KILL CLINIC
- +8 SET COST=$SELECT(+$PIECE(RX0,"^",17):+$PIECE(RX0,"^",17),$DATA(^PSDRUG(DRUG,660)):+$PIECE(^(660),"^",6),1:0)
- +9 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)
- +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)
- SET RF=0
- SET RX1=^PSRX(RXN,"P",RXF,0)
- SET DIV=$SELECT($PIECE(RX1,"^",9):$PIECE(RX1,"^",9),1:$PIECE(RX2,"^",9))
- DO SET
- DO REF
- SET TNP=TNP+1
- End DoDot:1
- SET PR=0
- QUIT
- +13 IF $PIECE(RX2,"^",13)
- IF 'RXF
- SET OR=OR+1
- SET COST=QTY*COST
- DO SET
- DO SF
- SET TNO=TNO+1
- QUIT
- +14 if RXF
- Begin DoDot:1
- +15 IF '$DATA(^PSRX(RXN,1,RXF,0))
- KILL ^PSRX("AL",PSDT,RXN,RXF)
- QUIT
- +16 IF $PIECE(^PSRX(RXN,1,RXF,0),"^",18)
- SET RF=0
- SET RX1=^PSRX(RXN,1,RXF,0)
- SET DIV=$SELECT($PIECE(RX1,"^",9):$PIECE(RX1,"^",9),1:$PIECE(RX2,"^",9))
- DO SET
- DO REF
- SET TNR=TNR+1
- End DoDot:1
- +17 QUIT
- SF SET DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD
- +1 if '$DATA(^TMP($JOB,"PAT",$PIECE(PSDT,"."),DIV,DFN))
- SET ^TMP($JOB,"PAT",$PIECE(PSDT,"."),DIV,DFN)=""
- +2 FOR I=1:1:PSG
- if ('$DATA(CLINIC))&(I=PSG)
- QUIT
- SET DATA1=$SELECT(($DATA(@(PSOA(I)))#2):^(0),1:@(PSOB(I))_"^0^0^0^0")
- SET DATA2=+$PIECE(DATA1,"^")
- Begin DoDot:1
- +3 FOR II=2:1:7
- SET VALUE=$PIECE(DATA,"^",II)+$PIECE(DATA1,"^",II)
- SET DATA2=DATA2_"^"_VALUE
- if II=7
- SET @PSOA(I)=DATA2
- +4 if '$DATA(@PSOA1(I))
- SET @PSOA1(I)=PSOB1(I)
- SET $PIECE(@PSOA1(I),"^",4)=+$PIECE(@PSOA1(I),"^",4)+1
- SET $PIECE(@PSOA1(I),"^",3)=@PSOB(I)
- End DoDot:1
- +5 FOR I=1:1:PSD
- SET DATA1=$SELECT(($DATA(@(PSOC(I)))#2):$GET(^(0)),1:@(PSOD(I))_"^0^0^0^0")
- SET DATA2=+$PIECE(DATA1,"^")
- Begin DoDot:1
- +6 FOR II=2:1:7
- SET VALUE=$PIECE(DATA,"^",II)+$PIECE(DATA1,"^",II)
- SET DATA2=DATA2_"^"_VALUE
- if II=7
- SET @PSOC(I)=DATA2
- Begin DoDot:2
- End DoDot:2
- +7 if '$DATA(@PSOC1(I))
- SET @PSOC1(I)=PSOD1(I)
- SET $PIECE(@PSOC1(I),"^",4)=+$PIECE(@PSOC1(I),"^",4)+1
- SET $PIECE(@PSOC1(I),"^",3)=@PSOD(I)
- End DoDot:1
- +8 QUIT
- SET SET ^PSCST($PIECE(PSDT,"."),0)=$PIECE(PSDT,".")
- SET ^PSCST("B",$PIECE(PSDT,"."),$PIECE(PSDT,"."))=""
- QUIT
- +1 ;
- MTH SET X1=DT
- SET X2=-1
- DO C^%DTC
- SET (BDT,EDT)=$EXTRACT(X,1,5)_"00"
- +1 FOR PSDT=(BDT+1):1:X
- KILL ^PSCST(PSDT),^PSCST("B",PSDT)
- +2 DO START^PSOCSTM
- GOTO EX
- +3 QUIT
- REF SET OR=0
- SET COST=$SELECT(+$PIECE(RX1,"^",11):+$PIECE(RX1,"^",11),$DATA(^PSDRUG(DRUG,660)):+$PIECE(^(660),"^",6),1:0)
- +1 SET RF=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)
- SET COST=QTY*COST
- +2 SET PHYS=$SELECT($PIECE(RX1,"^",17):$PIECE(RX1,"^",17),1:$PIECE(RX0,"^",4))
- DO SF
- +3 QUIT
- +4 ;
- G ;;
- +1 ;;^PSCST($P(PSDT,"."),0);PSDT;^TMP($J,"A1");1
- +2 ;;^PSCST($P(PSDT,"."),"P",PHYS,0);PHYS;^PSCST($P(PSDT,"."),"P",0);^50.9001PA^^
- +3 ;;^PSCST($P(PSDT,"."),"P",PHYS,"D",DRUG,0);DRUG;^PSCST($P(PSDT,"."),"P",PHYS,"D",0);^50.9002PA^^
- +4 ;;^PSCST($P(PSDT,"."),"D",DRUG,0);DRUG;^PSCST($P(PSDT,"."),"D",0);^50.9003PA^^
- +5 ;;^PSCST($P(PSDT,"."),"D",DRUG,"P",PHYS,0);PHYS;^PSCST($P(PSDT,"."),"D",DRUG,"P",0);^50.9004PA^^
- +6 ;;^PSCST($P(PSDT,"."),"PS",PAST,0);PAST;^PSCST($P(PSDT,"."),"PS",0);^50.9005PA^^
- +7 ;;^PSCST($P(PSDT,"."),"S",CLINIC,0);CLINIC;^PSCST($P(PSDT,"."),"S",0);^50.9008PA^^
- +8 ;;
- D ;;
- +1 ;;^PSCST($P(PSDT,"."),"V",DIV,0);DIV;^PSCST($P(PSDT,"."),"V",0);^50.9006PA^^
- +2 ;;^PSCST($P(PSDT,"."),"V",DIV,"D",DRUG,0);DRUG;^PSCST($P(PSDT,"."),"V",DIV,"D",0);^50.9007PA^^
- +3 ;;^PSCST($P(PSDT,"."),"V",DIV,"P",PHYS,0);PHYS;^PSCST($P(PSDT,"."),"V",DIV,"P",0);^50.901PA^^