- PSOMGCM1 ;BHAM ISC/JMB,SAB - management data compile/recompile ;4/15/05 3:10pm
- ;;7.0;OUTPATIENT PHARMACY;**20,28,175,185,198,444**;DEC 1997;Build 34
- ;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
- ;
- 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,QTYOVR90,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,TDAYS,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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOMGCM1 6548 printed Feb 18, 2025@23:57:26 Page 2
- PSOMGCM1 ;BHAM ISC/JMB,SAB - management data compile/recompile ;4/15/05 3:10pm
- +1 ;;7.0;OUTPATIENT PHARMACY;**20,28,175,185,198,444**;DEC 1997;Build 34
- +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 ;
- 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,QTYOVR90,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,TDAYS,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 FOR PDATE=SDT:1:EDT
- SET PP=$$RXSUM^FBRXUTL(PDATE,STN)
- if +PP<0
- QUIT
- if +PP>0
- Begin DoDot:1
- +5 SET PPCOST=$PIECE(PP,"^",2)
- SET PP=+PP
- DO SET
- End DoDot:1
- +6 IF +PP<0
- SET PP=$PIECE(PP,"^",3)
- GOTO MAIL
- +7 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