Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOCSTM.m

    r613 r623  
    1 PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;7/10/06 4:36pm
    2         ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212,246**;DEC 1997;Build 12
    3         ;External Ref. to ^PS(55 DBIA# 2228
    4         ;External Ref. to ^DPT DBIA# 10035
    5         ;External Ref. to ^PSDRUG DBIA# 221
    6         ;
    7         ;*212 don't allow this request, if monthly compile is running
    8         ;*246 alter SRCH1 For loop to not init to numeric values
    9         ;
    10         Q:$$MTHLCK(1)            ;get lock, quit if already locked    PSO*212
    11         K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00"
    12 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
    13         S BDT=Y
    14 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
    15         W ! S EDT=Y
    16         S ZTIO="",ZTRTN="START^PSOCSTM",ZTDESC="Rx Monthly Cost Compile" F G="EDT","BDT" S:$D(@G) ZTSAVE(G)=""
    17         D ^%ZTLOAD W:$D(ZTSK) !,"Task #"_ZTSK_" Queued!" K G,BDT,EDT,ZTSAVE,ZTIO,ZTRTN,ZTDESC Q
    18         L -^PSOCSTM                                    ;unlock month end flag
    19         ;
    20 START   Q:$$MTHLCK^PSOCSTM(1)      ;get lock, quit if already locked  PSO*212
    21         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)
    22         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)
    23         F PSDT=BDT:100:EDT K ^PSCST(PSDT),^PSCST("B",PSDT)
    24         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)
    25         K STOP
    26         ;
    27 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"
    28         S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT  S PSD=PSDT,PSOCNT=PSOCNT+1
    29         S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE
    30 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
    31         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="@"
    32         L -^PSOCSTM                                    ;unlock month end flag
    33         Q
    34         ;
    35 SRCH1   D INI
    36         ;refill
    37         S PSDT1=PSDT                                ;*246
    38         F  S PSDT1=$O(^PSRX("AL",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
    39         .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
    40         .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
    41         ;partial fill
    42         S PSDT1=PSDT                                ;*246
    43         F  S PSDT1=$O(^PSRX("AM",PSDT1)) Q:($E(PSDT1,1,7)<PSDT)!($E(PSDT1,1,7)>PSDTX)  D
    44         .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
    45         .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR
    46         Q
    47 INI     K VIS S (VISITS,DV)=0 F  S DV=$O(^PS(59,DV)) Q:'+DV  S VIS(DV)=0
    48         Q
    49 VST     S DV=0 F  S DV=$O(^TMP($J,"PAT",DV)) Q:'DV  D
    50         .S DFN=0 F  S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN  S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1
    51         K ^TMP($J,"PAT") Q
    52 CHK     I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
    53         Q:'$D(^PSRX(RXN,2))  S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2)
    54         S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0))  D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
    55         S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0))
    56         ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0))
    57         S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0))
    58         S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0))
    59         S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0))
    60         S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC
    61         S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0)
    62         I $G(PAR) D  S PR=0 Q
    63         .I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q
    64         .I $P(^PSRX(RXN,"P",RXF,0),"^",19) D
    65         ..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
    66         ..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4))
    67         ..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) S COST=QTY*COST D SET,SF
    68         I $P(RX2,"^",13),'RXF D  Q
    69         .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
    70         D:RXF
    71         .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
    72         .Q:'$P(^PSRX(RXN,1,RXF,0),"^",18)  S RX1=^PSRX(RXN,1,RXF,0)
    73         .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) S COST=QTY*COST
    74         .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))
    75         .D SET,SF
    76         Q
    77 SF      S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)=""
    78         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
    79         .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2
    80         .S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I)
    81         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
    82         .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D
    83         .S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I)
    84         Q
    85         ;
    86 SET     S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q
    87 SET1    S ^PSCST(PSDT,1)=DT_"^"_VISITS
    88         S DV=0 F  S DV=$O(VIS(DV)) Q:'DV  S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV)
    89         Q
    90 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
    91 ZNODE   ;update zero nodes
    92         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))
    93         .F  S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ  S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V"
    94         ..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
    95         ..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0
    96         .S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0
    97         K NDZ,ND,NODE,NDZ2,NDZ1 Q
    98         ;
    99 MTHLCK(GET)     ;lock for month end run or query if month end is running
    100         ; INPUT:  GET = 1  try to get lock and keep locked
    101         ;               0  query if locked only, leave as unlocked
    102         ; RETURNS: 1 - already locked
    103         ;          0 - was not already locked
    104         ;
    105         I '$D(ZTQUEUED) W !,"checking for duplicate job..."
    106         N GOTLOCK
    107         L +^PSOCSTM:10 S GOTLOCK=$T   ;delay 10 secs to handle slower systems
    108         I GOTLOCK,'GET L -^PSOCSTM Q 0
    109         I GOTLOCK,GET Q 0
    110         N AST S AST="",$P(AST,"*",79)=""
    111         D:'($D(ZTQUEUED))
    112         .W !!,*7,AST,!
    113         .W "Monthly Rx Cost Compilation is currently running, "
    114         .W "Try your request later",!
    115         .W AST,!!
    116         Q 1
    117         ;
    118         ;
    119 G       ;;
    120         ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1
    121         ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^
    122         ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^
    123         ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^
    124         ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^
    125         ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^
    126         ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^
    127         ;;
    128 D       ;;
    129         ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^
    130         ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^
    131         ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^
     1PSOCSTM ;BHAM ISC/SAB - monthly rx cost compilation ;9/14/05 1:13pm
     2 ;;7.0;OUTPATIENT PHARMACY;**4,17,19,28,89,212**;DEC 1997
     3 ;External Ref. to ^PS(55 DBIA# 2228
     4 ;External Ref. to ^DPT DBIA# 10035
     5 ;External Ref. to ^PSDRUG DBIA# 221
     6 ;
     7 ;PSO*212 don't allow this request, if monthly compile is running
     8 ;
     9 Q:$$MTHLCK(1)            ;get lock, quit if already locked    PSO*212
     10 K BDT,EDT W !!,"**** Date Range Selection ****" S LATE=$E(DT,1,5)_"00"
     11BEG 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
     12 S BDT=Y
     13END 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
     14 W ! S EDT=Y
     15 S ZTIO="",ZTRTN="START^PSOCSTM",ZTDESC="Rx Monthly Cost Compile" F G="EDT","BDT" S:$D(@G) ZTSAVE(G)=""
     16 D ^%ZTLOAD W:$D(ZTSK) !,"Task #"_ZTSK_" Queued!" K G,BDT,EDT,ZTSAVE,ZTIO,ZTRTN,ZTDESC Q
     17 L -^PSOCSTM                                    ;unlock month end flag
     18 ;
     19START Q:$$MTHLCK^PSOCSTM(1)      ;get lock, quit if already locked  PSO*212
     20 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)
     21 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)
     22 F PSDT=BDT:100:EDT K ^PSCST(PSDT),^PSCST("B",PSDT)
     23 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)
     24 K STOP
     25 ;
     26SRCH 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"
     27 S PSOCNT=0 F PSDT=0:0 S PSDT=$O(^PSCST("B",PSDT)) Q:'PSDT  S PSD=PSDT,PSOCNT=PSOCNT+1
     28 S ^PSCST(0)="DRUG COST^50.9D^"_PSD_"^"_PSOCNT D ZNODE
     29Q 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
     30 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="@"
     31 L -^PSOCSTM                                    ;unlock month end flag
     32 Q
     33 ;
     34SRCH1 D INI F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AL",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
     35 .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
     36 .S NDT=$O(^PSRX("AL",PSDT1)) D:$P(NDT,".")'=CDT VST
     37 F PSDT1=PSDT:0:PSDTX S PSDT1=$O(^PSRX("AM",PSDT1)) Q:'PSDT1!($E(PSDT1,1,7)>PSDTX)  D
     38 .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
     39 .S NDT=$O(^PSRX("AM",PSDT1)) D:$P(NDT,".")'=CDT VST K PAR
     40 Q
     41INI K VIS S (VISITS,DV)=0 F  S DV=$O(^PS(59,DV)) Q:'+DV  S VIS(DV)=0
     42 Q
     43VST S DV=0 F  S DV=$O(^TMP($J,"PAT",DV)) Q:'DV  D
     44 .S DFN=0 F  S DFN=$O(^TMP($J,"PAT",DV,DFN)) Q:'DFN  S VIS(DV)=VIS(DV)+1,VISITS=VISITS+1
     45 K ^TMP($J,"PAT") Q
     46CHK I '$D(^PSRX(RXN,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
     47 Q:'$D(^PSRX(RXN,2))  S RX0=^PSRX(RXN,0),RX2=^PSRX(RXN,2)
     48 S DFN=+$P(RX0,"^",2) Q:'$D(^DPT(DFN,0))  D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
     49 S DRG=+$P(RX0,"^",6) Q:'$D(^PSDRUG(DRG,0))
     50 ;S CLASS=+$P(^(0),"^",2) Q:'$D(^PS(50.605,CLASS,0))
     51 S DIV=+$P(RX2,"^",9) Q:'$D(^PS(59,DIV,0))
     52 S PHYS=+$P(RX0,"^",4) Q:'$D(^VA(200,PHYS,0))
     53 S PAST=+$P(RX0,"^",3) Q:'$D(^PS(53,PAST,0))
     54 S CLINIC=+$P(RX0,"^",5) K:'$D(^SC(CLINIC,0)) CLINIC
     55 S COST=$S(+$P(RX0,"^",17):+$P(RX0,"^",17),$D(^PSDRUG(DRG,660)):+$P(^(660),"^",6),1:0)
     56 I $G(PAR) D  S PR=0 Q
     57 .I '$D(^PSRX(RXN,"P",RXF,0)) K ^PSRX("AM",PSDT,RXN,RXF) Q
     58 .I $P(^PSRX(RXN,"P",RXF,0),"^",19) D
     59 ..S RX1=^PSRX(RXN,"P",RXF,0),DIV=$S($P(RX1,"^",9):$P(RX1,"^",9),1:$P(RX2,"^",9))
     60 ..S PHYS=$S($P(RX1,"^",17):$P(RX1,"^",17),1:$P(RX0,"^",4))
     61 ..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) S COST=QTY*COST D SET,SF
     62 I $P(RX2,"^",13),'RXF D  Q
     63 .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
     64 D:RXF
     65 .I '$D(^PSRX(RXN,1,RXF,0)) K ^PSRX("AL",PSDT,RXN,RXF) Q
     66 .Q:'$P(^PSRX(RXN,1,RXF,0),"^",18)  S RX1=^PSRX(RXN,1,RXF,0)
     67 .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) S COST=QTY*COST
     68 .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))
     69 .D SET,SF
     70 Q
     71SF S DATA="^"_OR_"^"_RF_"^"_COST_"^"_QTY_"^"_ML_"^"_WD,^TMP($J,"PAT",DIV,DFN)=""
     72 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
     73 .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @A(I)=DATA2
     74 .S:'$D(@A1(I)) @A1(I)=B1(I) S $P(@A1(I),"^",4)=+$P(@A1(I),"^",4)+1,$P(@A1(I),"^",3)=@B(I)
     75 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
     76 .F II=2:1:7 S VALUE=$P(DATA,"^",II)+$P(DATA1,"^",II),DATA2=DATA2_"^"_VALUE S:II=7 @C(I)=DATA2 D
     77 .S:'$D(@C1(I)) @C1(I)=D1(I) S $P(@C1(I),"^",4)=+$P(@C1(I),"^",4)+1,$P(@C1(I),"^",3)=@D(I)
     78 Q
     79 ;
     80SET S:'$D(^PSCST(PSDT,0)) ^PSCST(PSDT,0)=PSDT,^PSCST("B",PSDT,PSDT)="" Q
     81SET1 S ^PSCST(PSDT,1)=DT_"^"_VISITS
     82 S DV=0 F  S DV=$O(VIS(DV)) Q:'DV  S $P(^PSCST(PSDT,"V",DV,0),"^",8)=+VIS(DV)
     83 Q
     84QUES 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
     85ZNODE ;update zero nodes
     86 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))
     87 .F  S NDZ=$O(^PSCST(PSDT,ND,NDZ)) Q:'NDZ  S NODE(ND)=NODE(ND)+1,NDZ2=NDZ D:ND="V"
     88 ..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
     89 ..S $P(^PSCST(PSDT,ND,NDZ2,"P",0),"^",4)=NODE(ND,"P"),NDZ1=0
     90 .S:$G(^PSCST(PSDT,ND,0))]"" $P(^PSCST(PSDT,ND,0),"^",4)=NODE(ND),NDZ=0
     91 K NDZ,ND,NODE,NDZ2,NDZ1 Q
     92 ;
     93MTHLCK(GET) ;lock for month end run or query if month end is running
     94 ; INPUT:  GET = 1  try to get lock and keep locked
     95 ;               0  query if locked only, leave as unlocked
     96 ; RETURNS: 1 - already locked
     97 ;          0 - was not already locked
     98 ;
     99 I '$D(ZTQUEUED) W !,"checking for duplicate job..."
     100 N GOTLOCK
     101 L +^PSOCSTM:10 S GOTLOCK=$T   ;delay 10 secs to handle slower systems
     102 I GOTLOCK,'GET L -^PSOCSTM Q 0
     103 I GOTLOCK,GET Q 0
     104 N AST S AST="",$P(AST,"*",79)=""
     105 D:'($D(ZTQUEUED))
     106 .W !!,*7,AST,!
     107 .W "Monthly Rx Cost Compilation is currently running, "
     108 .W "Try your request later",!
     109 .W AST,!!
     110 Q 1
     111 ;
     112 ;
     113G ;;
     114 ;;^PSCST(PSDT,0);PSDT;^TMP($J,"A1");1
     115 ;;^PSCST(PSDT,"P",PHYS,0);PHYS;^PSCST(PSDT,"P",0);^50.9001PA^^
     116 ;;^PSCST(PSDT,"P",PHYS,"D",DRG,0);DRG;^PSCST(PSDT,"P",PHYS,"D",0);^50.9002PA^^
     117 ;;^PSCST(PSDT,"D",DRG,0);DRG;^PSCST(PSDT,"D",0);^50.9003PA^^
     118 ;;^PSCST(PSDT,"D",DRG,"P",PHYS,0);PHYS;^PSCST(PSDT,"D",DRG,"P",0);^50.9004PA^^
     119 ;;^PSCST(PSDT,"PS",PAST,0);PAST;^PSCST(PSDT,"PS",0);^50.9005PA^^
     120 ;;^PSCST(PSDT,"S",CLINIC,0);CLINIC;^PSCST(PSDT,"S",0);^50.9008PA^^
     121 ;;
     122D ;;
     123 ;;^PSCST(PSDT,"V",DIV,0);DIV;^PSCST(PSDT,"V",0);^50.9006PA^^
     124 ;;^PSCST(PSDT,"V",DIV,"D",DRG,0);DRG;^PSCST(PSDT,"V",DIV,"D",0);^50.9007PA^^
     125 ;;^PSCST(PSDT,"V",DIV,"P",PHYS,0);PHYS;^PSCST(PSDT,"V",DIV,"P",0);^50.901PA^^
Note: See TracChangeset for help on using the changeset viewer.