source: WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSGTCTD.m@ 767

Last change on this file since 767 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.0 KB
RevLine 
[613]1PSGTCTD ;BIR/CML3-SHOW TOTAL COST TO DATE OF PATIENTS ; 15 May 98 / 9:26 AM
2 ;;5.0; INPATIENT MEDICATIONS ;**3**;16 DEC 97
3START ;
4 D ENCV^PSGSETU I '$D(XQUIT) S PSGSSH="TCR",PSJACNWP=1,(PSGWG,PSGWD,PSGPAT)=0 D ^PSGSEL I "^"'[PSGSS D @PSGSS I +Y>0 D DEV I 'POP,'$D(IO("Q")) D ENQ,^%ZISC
5 ;
6DONE ;
7 D ENKV^PSGSETU K AMT,CNTR,COST,DRG,DRGN,LN2,ND,PSJJORD,PSGDICA,PSGP,PSGPAT,PSGPN,PSGSS,PSGSSH,PSGWD,PSGWDN,PSGWG,PSN,SD,ZTOUT Q
8 ;
9ENQ ;
10 D NOW^%DTC S PSGDT=%,DT=$P(%,".") K ^TMP("PSG",$J) D @("G"_PSGSS),^PSGTCTD0
11 K ^TMP("PSG",$J) Q
12 ;
13GG ;
14 F PSGWD=0:0 S PSGWD=$O(^PS(57.5,"AC",PSGWG,PSGWD)) Q:'PSGWD D GW
15 Q
16 ;
17GW ;
18 I $D(^DIC(42,PSGWD,0)),$P(^(0),"^")]"" S PSGWDN=$P(^(0),"^") F PSGP=0:0 S PSGP=$O(^DPT("CN",PSGWDN,PSGP)) Q:'PSGP D PAT
19 Q
20 ;
21GP ;
22 F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP D PAT
23 Q
24 ;
25PAT ;
26 S COST=0 D ^PSJAC S PSGPN=$S($P(PSGP(0),"^")]"":$P(PSGP(0),"^"),1:PSGP)_"^"_PSGP,PSN=$E($P(PSJPSSN,"^"),6,10)
27 F SD=+PSJPAD:0 S SD=$O(^PS(55,PSGP,5,"AUS",SD)) Q:'SD F PSJJORD=0:0 S PSJJORD=$O(^PS(55,PSGP,5,"AUS",SD,PSJJORD)) Q:'PSJJORD D ADD
28 S:$D(^TMP("PSG",$J,PSGPN)) ^(PSGPN)=$P(PSJPAD,"^",2)_"^"_PSN_"^"_PSJPDX Q
29 ;
30ADD ;
31 N X F X=0:0 S X=$O(^PS(55,PSGP,5,PSJJORD,1,X)) Q:'X D
32 .; naked ref below refers to line above
33 .S ND=^(X,0),DRG=+ND,DRGN=$G(^PSDRUG(DRG,0)),DRGN=$S($P(DRGN,"^")]"":$P(DRGN,"^"),1:DRG)_$S('$P(DRGN,"^",9):"",1:"^1"),DRG=+$P($G(^(660)),"^",6)
34 .S AMT=$P(ND,"^",6)+$P(ND,"^",10)+$P(ND,"^",12)-$P(ND,"^",7) I DRG*AMT S ND=$G(^TMP("PSG",$J,PSGPN,DRGN)),^(DRGN)=+ND+AMT_"^"_(DRG*AMT+$P(ND,"^",2))
35 Q
36 ;
37G ;
38 S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC K DIC S PSGWG=+Y Q
39W ;
40 S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC K DIC S PSGWD=+Y Q
41P ;
42 K PSGPAT S PSGPAT=0 F CNTR=1:1 S:CNTR>1 PSGDICA="another" D ENDPT^PSGP Q:PSGP'>0 S PSGPAT(PSGP)="",PSGPAT=PSGP
43 S Y=PSGPAT Q
44 ;
45DEV ;
46 K ZTSAVE S PSGTIR="ENQ^PSGTCTD",ZTDESC="TOTAL COST REPORT" F X="PSGSS","PSGWG","PSGWD","PSGPAT(" S ZTSAVE(X)=""
47 D ENDEV^PSGTI Q
Note: See TracBrowser for help on using the repository browser.