PSOMGCM1 ;BHAM ISC/JMB,SAB - management data compile/recompile ;29-May-2012 14:54;PLS
;;7.0;OUTPATIENT PHARMACY;**20,28,175,1005,185,198,1015**;DEC 1997;Build 62
;Ref. to $$RXSUM^FBRXUTL supp. by IA# 4395
;Ref. to ^PSDRUG(, supp. by IA# 221
;PSO*198 correct begin date to previous day @ time 999999
; Modified - IHS/MSC/PLS - 3/28/06 - Added Line FBA+4
END K ^TMP($J),%DT,AVGCAT,AVGEQFL,AVGFEE,AVGST,CAT,CATA,CATC,CATCOST,COST,DA,DATE,DIC,DINUM,DFN,DIRUT,DIV,DV,EQCOST,EQFL,EQPREQ,DRUG,EDT,FEE,FCOST,INV,MAIL,METH,NEW,METH,METHAD,OTH,PCAT,PHYS,PP,PPCOST,PREQ,PDATE,RECOM
K QTY30,QTY60,QTY90,QTY90P,QTY120,QTY179,QTY180,REC,R,REF,RX0,RXF,RXPREQ,SDT,ST,STAFF,STCOST,SUB,VAEL,WIND,AVGMETH,COSTPST,METHCOST,PCPP,NODE1,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
K TFIL,TFTY,TFCT,TY,NDT,DAYS,COM,STN S:$D(ZTQUEUED) ZTREQ="@"
Q
PURG ;purge data for a date range
W !,"Purge Management Statistics",!! S SDT=$O(^PS(59.12,0)) I $D(SDT) S Y=SDT D DD^%DT S %DT("B")=Y
S %DT(0)=-DT,%DT("A")="Starting date: " S %DT="EPXA" D ^%DT G:"^"[X END G RECOM:'Y S SDT=Y K %DT(0) S Y=SDT D DD^%DT S SY=Y K %DT("B"),Y
PDT W ! S %DT(0)=SDT,%DT("A")=" Ending date: " D ^%DT G:"^"[X END G:Y<0 PDT S EDT=Y W !
W !,$C(7),$C(7) S Y=EDT D DD^%DT W !!!,"Purge from "_SY_" to "_Y,!
S DIR("A")="Are you sure",DIR(0)="Y",DIR("B")="N" D ^DIR K DIR I $G(DIRUT)!('Y) K EDT,SDT,SY,Y W !,$C(7),"No data has been purged." Q
S ZTDTH="",ZTRTN="P^PSOMGCM1",ZTDESC="Outpatient Pharmacy Management Data Purge",ZTIO="" F G="SDT","EDT" S:$D(@G) ZTSAVE(G)=""
D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued !",! K SDT,EDT,G,ZTSK,ZTIO S:$D(ZTQUEUED) ZTREQ="@"
Q
P S DIK="^PS(59.12," F DA=SDT-1:0 S DA=$O(^PS(59.12,DA)) Q:'DA!(DA>EDT) D ^DIK
K DIK Q
TSK ;initialize nightly mgmt. compile job
D SETUP1^PSOAUTOC
W ! K DIR S DIR("B")="NO",DIR(0)="Y",DIR("A")="Do you want to compile data prior to yesterday" D ^DIR I 'Y!($D(DIRUT)) G EX
D RECOM
EX K DIR,X,Y
Q
TASK ;compile every night
S X1=DT,X2=-1 D C^%DTC S (EDT,SDT)=X K X1,X2 D BEG
Q
QUE S ZTDTH=$H+1_",3600",ZTIO="",ZTRTN="TASK^PSOMGCM1",ZTDESC="Outpatient Pharmacy Daily Compile of Management Data",ZTIO=""
D ^%ZTLOAD W:$D(ZTSK)&('$D(ZTQUEUED)) !!,"Task Queued !",! K DAY,SDT,EDT,G,ZTSK,ZTIO S:$D(ZTQUEUED) ZTREQ="@"
Q
DAY ;recompile by day
W ! S %DT(0)=-DT,%DT("A")="Date: " S %DT="EPXA" D ^%DT G:"^"[X END G DAY:'Y S (SDT,EDT)=Y K %DT(0) S COM=1 W !
G Q
RECOM ;recompile data for a date range
W ! S %DT(0)=-DT,%DT("A")="Starting date: " S %DT="EPXA" D ^%DT G:"^"[X END G RECOM:'Y S SDT=Y K %DT(0)
REDT W ! S %DT(0)=SDT,%DT("A")=" Ending date: " D ^%DT G:"^"[X END I Y<0!(Y>DT) W " ??" G REDT
S EDT=Y S COM="R" W !
Q S ZTDTH="",ZTRTN="BEG^PSOMGCM1",ZTDESC="Outpatient Pharmacy Management Data Recompile "_$S(COM:"One Day",1:"Range of Days"),ZTIO="" F G="SDT","EDT" S:$D(@G) ZTSAVE(G)=""
D ^%ZTLOAD W:$D(ZTSK) !!,"Task Queued !",! K SDT,EDT,G,ZTSK,ZTIO S:$D(ZTQUEUED) ZTREQ="@"
Q
BEG S DIK="^PS(59.12,",DA=SDT-1 F S DA=$O(^PS(59.12,DA)) Q:'DA!(DA>EDT) D ^DIK
K DA,DIK F NDT=SDT:1:EDT D BEG1
D FBA G END
Q
;PSO*198 seed loop to previous day @ time 999999
BEG1 K ^TMP($J) D CLE^PSOMGCOM F TY="AL","AM" S PDATE=NDT-1+.999999 F S PDATE=$O(^PSRX(TY,PDATE)) Q:'PDATE!(PDATE>(NDT_".999999")) D BEG2
S PDATE=NDT D:TFIL ADD,BUILD^PSOMGCOM
Q
BEG2 S REC=0 F S REC=$O(^PSRX(TY,PDATE,REC)) Q:'REC D BEG3
Q
BEG3 Q:'$D(^PSRX(REC,0)) S DA="" F S DA=$O(^PSRX(TY,PDATE,REC,DA)) Q:DA="" D
.S RX0=^PSRX(REC,0),DFN=$P(RX0,"^",2),ST=$P(RX0,"^",3),PHYS=$P(RX0,"^",4),DRUG=$P(RX0,"^",6),DAYS=$P(RX0,"^",8)
.Q:'DFN!('DRUG) D:TY="AL" COM1^PSOMGCOM D:TY="AM" COM2
Q
COM2 Q:'$P($G(^PSRX(REC,"P",DA,0)),"^",19)
S RXF=^PSRX(REC,"P",DA,0),DV=$S($P(RXF,"^",9):$P(RXF,"^",9),1:$O(^PS(59,0))),REF(DV)=REF(DV)+1 S:$P(RXF,"^",2)="W" WIND(DV)=WIND(DV)+1 S:$P(RXF,"^",2)="M" MAIL(DV)=MAIL(DV)+1 S DATE=$P(^PSRX(REC,"P",0),"^")-.01
S COST=$P(RXF,"^",4)*$S($P(RXF,"^",11):$P(RXF,"^",11),1:+$P($G(^PSDRUG(+$P(^PSRX(REC,0),"^",6),660)),"^",6))
D DAYS^PSOMGCOM,STA^PSOMGCOM
Q
FBA S (STN,DV)=0 S:'$G(DT) DT=$$DT^XLFDT
F S DV=$O(^PS(59,DV)) Q:'DV D Q:STN
.I '$G(^PS(59,DV,"I"))!(DT'>$G(^PS(59,DV,"I"))) S STN=$P(^("INI"),"^"),STN=+$$GET1^DIQ(4,STN,99)
I 'STN S PP="Invalid Related Institution in File #59" G MAIL
S X="FBRXUTL" X ^%ZOSF("TEST") Q:'$T ;IHS/MSC/PLS - 03/28/06 Call not used in IHS
F PDATE=SDT:1:EDT S PP=$$RXSUM^FBRXUTL(PDATE,STN) Q:+PP<0 D:+PP>0
.S PPCOST=$P(PP,"^",2),PP=+PP D SET
I +PP<0 S PP=$P(PP,"^",3) G MAIL
Q
MAIL F PSO1=0:0 S PSO1=$O(^XUSEC("PSORPH",PSO1)) Q:'PSO1 S XMY(PSO1)=""
Q:$O(XMY(""))=""
S XMDUZ="Outpatient Pharmacy Package"
S XMSUB="FEE Basis Cost Data - Incomplete Nightly Job"
S PP=$E(PP_". ",1,42)
S PSO(1)="**************************************************"
S PSO(2)="*** FEE Basis Cost data was not collected for ***"
S PSO(3)="*** the period "_$E(SDT,4,5)_"/"_$E(SDT,6,7)_"/"_$E(SDT,2,3)_" to "_$E(EDT,4,5)_"/"_$E(EDT,6,7)_"/"_$E(EDT,2,3)_". ***"
S PSO(4)="*** ***"
S PSO(5)="*** The reason reported was: ***"
S PSO(6)="*** "_PP_" ***"
S PSO(7)="*** ***"
S PSO(8)="*** You may have to manually recompile this ***"
S PSO(9)="*** data at a later date. ***"
S PSO(10)="**************************************************"
S XMTEXT="PSO(" N DIFROM D ^XMD K XMSUB,XMDUZ,XMTEXT,PSO,PSO1
Q
SET I '$D(^PS(59.12,PDATE,0)) D ADD S DV=0 F S DV=$O(^PS(59,DV)) Q:'+DV D
.S ^PS(59.12,PDATE,1,DV,0)=DV_"^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0",^PS(59.12,PDATE,2,DV,0)=DV_"^0^0^0^0^0^0^0^0^0^0^0^0^0.0",^PS(59.12,PDATE,3,DV,0)=DV_"^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
S DV=0,DV=$O(^PS(59,DV)),$P(^PS(59.12,PDATE,2,DV,0),"^",13)=PP,FEE=0
F DIV=0:0 S DIV=$O(^PS(59.12,PDATE,2,DIV)) Q:'+DIV S FEE=FEE+$P(^PS(59.12,PDATE,2,DIV,0),"^",3)
S $P(^PS(59.12,PDATE,2,DV,0),"^",14)=$FN($S(FEE=0:100.0,$P(^PS(59.12,PDATE,2,DV,0),"^",13)=0:0,1:(FEE/(FEE+$P(^PS(59.12,$P(PDATE,"."),2,DV,0),"^",13)))*100),"",1)
S $P(^PS(59.12,PDATE,3,DV,0),"^",9)=$FN(PPCOST,"",2),$P(^PS(59.12,PDATE,3,DV,0),"^",10)=$FN($S(PPCOST=0!(PP=0):0,1:PPCOST/PP),"",2)
Q
ADD S (X,DINUM)=PDATE,DIC="^PS(59.12,",DIC(0)="L" K DD,DO D FILE^DICN F DV=0:0 S DV=$O(^PS(59,DV)) Q:'+DV D ADDEM
Q
ADDEM S ^PS(59.12,PDATE,1,0)="^59.121A^"_DV_"^"_TFIL,^PS(59.12,PDATE,1,DV,0)=DV,^PS(59.12,PDATE,1,"B",DV,DV)=""
S ^PS(59.12,PDATE,2,0)="^59.122A^"_DV_"^"_TFTY,^PS(59.12,PDATE,2,DV,0)=DV,^PS(59.12,PDATE,2,"B",DV,DV)=""
S ^PS(59.12,PDATE,3,0)="^59.123A^"_DV_"^"_TFCT,^PS(59.12,PDATE,3,DV,0)=DV,^PS(59.12,PDATE,3,"B",DV,DV)=""
Q
PSOMGCM1 ;BHAM ISC/JMB,SAB - management data compile/recompile ;29-May-2012 14:54;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**20,28,175,1005,185,198,1015**;DEC 1997;Build 62
+2 ;Ref. to $$RXSUM^FBRXUTL supp. by IA# 4395
+3 ;Ref. to ^PSDRUG(, supp. by IA# 221
+4 ;PSO*198 correct begin date to previous day @ time 999999
+5 ; Modified - IHS/MSC/PLS - 3/28/06 - Added Line FBA+4
END KILL ^TMP($JOB),%DT,AVGCAT,AVGEQFL,AVGFEE,AVGST,CAT,CATA,CATC,CATCOST,COST,DA,DATE,DIC,DINUM,DFN,DIRUT,DIV,DV,EQCOST,EQFL,EQPREQ,DRUG,EDT,FEE,FCOST,INV,MAIL,METH,NEW,METH,METHAD,OTH,PCAT,PHYS,PP,PPCOST,PREQ,PDATE,RECOM
+1 KILL QTY30,QTY60,QTY90,QTY90P,QTY120,QTY179,QTY180,REC,R,REF,RX0,RXF,RXPREQ,SDT,ST,STAFF,STCOST,SUB,VAEL,WIND,AVGMETH,COSTPST,METHCOST,PCPP,NODE1,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE
+2 KILL TFIL,TFTY,TFCT,TY,NDT,DAYS,COM,STN
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
PURG ;purge data for a date range
+1 WRITE !,"Purge Management Statistics",!!
SET SDT=$ORDER(^PS(59.12,0))
IF $DATA(SDT)
SET Y=SDT
DO DD^%DT
SET %DT("B")=Y
+2 SET %DT(0)=-DT
SET %DT("A")="Starting date: "
SET %DT="EPXA"
DO ^%DT
IF "^"[X
GOTO END
IF 'Y
GOTO RECOM
SET SDT=Y
KILL %DT(0)
SET Y=SDT
DO DD^%DT
SET SY=Y
KILL %DT("B"),Y
PDT WRITE !
SET %DT(0)=SDT
SET %DT("A")=" Ending date: "
DO ^%DT
IF "^"[X
GOTO END
IF Y<0
GOTO PDT
SET EDT=Y
WRITE !
+1 WRITE !,$CHAR(7),$CHAR(7)
SET Y=EDT
DO DD^%DT
WRITE !!!,"Purge from "_SY_" to "_Y,!
+2 SET DIR("A")="Are you sure"
SET DIR(0)="Y"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $GET(DIRUT)!('Y)
KILL EDT,SDT,SY,Y
WRITE !,$CHAR(7),"No data has been purged."
QUIT
+3 SET ZTDTH=""
SET ZTRTN="P^PSOMGCM1"
SET ZTDESC="Outpatient Pharmacy Management Data Purge"
SET ZTIO=""
FOR G="SDT","EDT"
IF $DATA(@G)
SET ZTSAVE(G)=""
+4 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !!,"Task Queued !",!
KILL SDT,EDT,G,ZTSK,ZTIO
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
P SET DIK="^PS(59.12,"
FOR DA=SDT-1:0
SET DA=$ORDER(^PS(59.12,DA))
IF 'DA!(DA>EDT)
QUIT
DO ^DIK
+1 KILL DIK
QUIT
TSK ;initialize nightly mgmt. compile job
+1 DO SETUP1^PSOAUTOC
+2 WRITE !
KILL DIR
SET DIR("B")="NO"
SET DIR(0)="Y"
SET DIR("A")="Do you want to compile data prior to yesterday"
DO ^DIR
IF 'Y!($DATA(DIRUT))
GOTO EX
+3 DO RECOM
EX KILL DIR,X,Y
+1 QUIT
TASK ;compile every night
+1 SET X1=DT
SET X2=-1
DO C^%DTC
SET (EDT,SDT)=X
KILL X1,X2
DO BEG
+2 QUIT
QUE SET ZTDTH=$HOROLOG+1_",3600"
SET ZTIO=""
SET ZTRTN="TASK^PSOMGCM1"
SET ZTDESC="Outpatient Pharmacy Daily Compile of Management Data"
SET ZTIO=""
+1 DO ^%ZTLOAD
IF $DATA(ZTSK)&('$DATA(ZTQUEUED))
WRITE !!,"Task Queued !",!
KILL DAY,SDT,EDT,G,ZTSK,ZTIO
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
DAY ;recompile by day
+1 WRITE !
SET %DT(0)=-DT
SET %DT("A")="Date: "
SET %DT="EPXA"
DO ^%DT
IF "^"[X
GOTO END
IF 'Y
GOTO DAY
SET (SDT,EDT)=Y
KILL %DT(0)
SET COM=1
WRITE !
+2 GOTO Q
RECOM ;recompile data for a date range
+1 WRITE !
SET %DT(0)=-DT
SET %DT("A")="Starting date: "
SET %DT="EPXA"
DO ^%DT
IF "^"[X
GOTO END
IF 'Y
GOTO RECOM
SET SDT=Y
KILL %DT(0)
REDT WRITE !
SET %DT(0)=SDT
SET %DT("A")=" Ending date: "
DO ^%DT
IF "^"[X
GOTO END
IF Y<0!(Y>DT)
WRITE " ??"
GOTO REDT
+1 SET EDT=Y
SET COM="R"
WRITE !
Q SET ZTDTH=""
SET ZTRTN="BEG^PSOMGCM1"
SET ZTDESC="Outpatient Pharmacy Management Data Recompile "_$SELECT(COM:"One Day",1:"Range of Days")
SET ZTIO=""
FOR G="SDT","EDT"
IF $DATA(@G)
SET ZTSAVE(G)=""
+1 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !!,"Task Queued !",!
KILL SDT,EDT,G,ZTSK,ZTIO
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
BEG SET DIK="^PS(59.12,"
SET DA=SDT-1
FOR
SET DA=$ORDER(^PS(59.12,DA))
IF 'DA!(DA>EDT)
QUIT
DO ^DIK
+1 KILL DA,DIK
FOR NDT=SDT:1:EDT
DO BEG1
+2 DO FBA
GOTO END
+3 QUIT
+4 ;PSO*198 seed loop to previous day @ time 999999
BEG1 KILL ^TMP($JOB)
DO CLE^PSOMGCOM
FOR TY="AL","AM"
SET PDATE=NDT-1+.999999
FOR
SET PDATE=$ORDER(^PSRX(TY,PDATE))
IF 'PDATE!(PDATE>(NDT_".999999"))
QUIT
DO BEG2
+1 SET PDATE=NDT
IF TFIL
DO ADD
DO BUILD^PSOMGCOM
+2 QUIT
BEG2 SET REC=0
FOR
SET REC=$ORDER(^PSRX(TY,PDATE,REC))
IF 'REC
QUIT
DO BEG3
+1 QUIT
BEG3 IF '$DATA(^PSRX(REC,0))
QUIT
SET DA=""
FOR
SET DA=$ORDER(^PSRX(TY,PDATE,REC,DA))
IF DA=""
QUIT
Begin DoDot:1
+1 SET RX0=^PSRX(REC,0)
SET DFN=$PIECE(RX0,"^",2)
SET ST=$PIECE(RX0,"^",3)
SET PHYS=$PIECE(RX0,"^",4)
SET DRUG=$PIECE(RX0,"^",6)
SET DAYS=$PIECE(RX0,"^",8)
+2 IF 'DFN!('DRUG)
QUIT
IF TY="AL"
DO COM1^PSOMGCOM
IF TY="AM"
DO COM2
End DoDot:1
+3 QUIT
COM2 IF '$PIECE($GET(^PSRX(REC,"P",DA,0)),"^",19)
QUIT
+1 SET RXF=^PSRX(REC,"P",DA,0)
SET DV=$SELECT($PIECE(RXF,"^",9):$PIECE(RXF,"^",9),1:$ORDER(^PS(59,0)))
SET REF(DV)=REF(DV)+1
IF $PIECE(RXF,"^",2)="W"
SET WIND(DV)=WIND(DV)+1
IF $PIECE(RXF,"^",2)="M"
SET MAIL(DV)=MAIL(DV)+1
SET DATE=$PIECE(^PSRX(REC,"P",0),"^")-.01
+2 SET COST=$PIECE(RXF,"^",4)*$SELECT($PIECE(RXF,"^",11):$PIECE(RXF,"^",11),1:+$PIECE($GET(^PSDRUG(+$PIECE(^PSRX(REC,0),"^",6),660)),"^",6))
+3 DO DAYS^PSOMGCOM
DO STA^PSOMGCOM
+4 QUIT
FBA SET (STN,DV)=0
IF '$GET(DT)
SET DT=$$DT^XLFDT
+1 FOR
SET DV=$ORDER(^PS(59,DV))
IF 'DV
QUIT
Begin DoDot:1
+2 IF '$GET(^PS(59,DV,"I"))!(DT'>$GET(^PS(59,DV,"I")))
SET STN=$PIECE(^("INI"),"^")
SET STN=+$$GET1^DIQ(4,STN,99)
End DoDot:1
IF STN
QUIT
+3 IF 'STN
SET PP="Invalid Related Institution in File #59"
GOTO MAIL
+4 ;IHS/MSC/PLS - 03/28/06 Call not used in IHS
SET X="FBRXUTL"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT
+5 FOR PDATE=SDT:1:EDT
SET PP=$$RXSUM^FBRXUTL(PDATE,STN)
IF +PP<0
QUIT
IF +PP>0
Begin DoDot:1
+6 SET PPCOST=$PIECE(PP,"^",2)
SET PP=+PP
DO SET
End DoDot:1
+7 IF +PP<0
SET PP=$PIECE(PP,"^",3)
GOTO MAIL
+8 QUIT
MAIL FOR PSO1=0:0
SET PSO1=$ORDER(^XUSEC("PSORPH",PSO1))
IF 'PSO1
QUIT
SET XMY(PSO1)=""
+1 IF $ORDER(XMY(""))=""
QUIT
+2 SET XMDUZ="Outpatient Pharmacy Package"
+3 SET XMSUB="FEE Basis Cost Data - Incomplete Nightly Job"
+4 SET PP=$EXTRACT(PP_". ",1,42)
+5 SET PSO(1)="**************************************************"
+6 SET PSO(2)="*** FEE Basis Cost data was not collected for ***"
+7 SET PSO(3)="*** the period "_$EXTRACT(SDT,4,5)_"/"_$EXTRACT(SDT,6,7)_"/"_$EXTRACT(SDT,2,3)_" to "_$EXTRACT(EDT,4,5)_"/"_$EXTRACT(EDT,6,7)_"/"_$EXTRACT(EDT,2,3)_". ***"
+8 SET PSO(4)="*** ***"
+9 SET PSO(5)="*** The reason reported was: ***"
+10 SET PSO(6)="*** "_PP_" ***"
+11 SET PSO(7)="*** ***"
+12 SET PSO(8)="*** You may have to manually recompile this ***"
+13 SET PSO(9)="*** data at a later date. ***"
+14 SET PSO(10)="**************************************************"
+15 SET XMTEXT="PSO("
NEW DIFROM
DO ^XMD
KILL XMSUB,XMDUZ,XMTEXT,PSO,PSO1
+16 QUIT
SET IF '$DATA(^PS(59.12,PDATE,0))
DO ADD
SET DV=0
FOR
SET DV=$ORDER(^PS(59,DV))
IF '+DV
QUIT
Begin DoDot:1
+1 SET ^PS(59.12,PDATE,1,DV,0)=DV_"^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0^0"
SET ^PS(59.12,PDATE,2,DV,0)=DV_"^0^0^0^0^0^0^0^0^0^0^0^0^0.0"
SET ^PS(59.12,PDATE,3,DV,0)=DV_"^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00^0.00"
End DoDot:1
+2 SET DV=0
SET DV=$ORDER(^PS(59,DV))
SET $PIECE(^PS(59.12,PDATE,2,DV,0),"^",13)=PP
SET FEE=0
+3 FOR DIV=0:0
SET DIV=$ORDER(^PS(59.12,PDATE,2,DIV))
IF '+DIV
QUIT
SET FEE=FEE+$PIECE(^PS(59.12,PDATE,2,DIV,0),"^",3)
+4 SET $PIECE(^PS(59.12,PDATE,2,DV,0),"^",14)=$FNUMBER($SELECT(FEE=0:100.0,$PIECE(^PS(59.12,PDATE,2,DV,0),"^",13)=0:0,1:(FEE/(FEE+$PIECE(^PS(59.12,$PIECE(PDATE,"."),2,DV,0),"^",13)))*100),"",1)
+5 SET $PIECE(^PS(59.12,PDATE,3,DV,0),"^",9)=$FNUMBER(PPCOST,"",2)
SET $PIECE(^PS(59.12,PDATE,3,DV,0),"^",10)=$FNUMBER($SELECT(PPCOST=0!(PP=0):0,1:PPCOST/PP),"",2)
+6 QUIT
ADD SET (X,DINUM)=PDATE
SET DIC="^PS(59.12,"
SET DIC(0)="L"
KILL DD,DO
DO FILE^DICN
FOR DV=0:0
SET DV=$ORDER(^PS(59,DV))
IF '+DV
QUIT
DO ADDEM
+1 QUIT
ADDEM SET ^PS(59.12,PDATE,1,0)="^59.121A^"_DV_"^"_TFIL
SET ^PS(59.12,PDATE,1,DV,0)=DV
SET ^PS(59.12,PDATE,1,"B",DV,DV)=""
+1 SET ^PS(59.12,PDATE,2,0)="^59.122A^"_DV_"^"_TFTY
SET ^PS(59.12,PDATE,2,DV,0)=DV
SET ^PS(59.12,PDATE,2,"B",DV,DV)=""
+2 SET ^PS(59.12,PDATE,3,0)="^59.123A^"_DV_"^"_TFCT
SET ^PS(59.12,PDATE,3,DV,0)=DV
SET ^PS(59.12,PDATE,3,"B",DV,DV)=""
+3 QUIT
