PSGTCTD ;BIR/CML3-SHOW TOTAL COST TO DATE OF PATIENTS ; 15 May 98 / 9:26 AM
;;5.0;INPATIENT MEDICATIONS ;**3,283**;16 DEC 97;Build 4
START ;
D ENCV^PSGSETU I '$D(XQUIT) S PSGSSH="TCR",PSJACNWP=1,(PSGWG,PSGWD,PSGPAT)=0 D NOCL^PSGSEL I "^"'[PSGSS D @PSGSS I +Y>0 D DEV I 'POP,'$D(IO("Q")) D ENQ,^%ZISC
;
DONE ;
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
;
ENQ ;
D NOW^%DTC S PSGDT=%,DT=$P(%,".") K ^TMP("PSG",$J) D @("G"_PSGSS),^PSGTCTD0
K ^TMP("PSG",$J) Q
;
GG ;
F PSGWD=0:0 S PSGWD=$O(^PS(57.5,"AC",PSGWG,PSGWD)) Q:'PSGWD D GW
Q
;
GW ;
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
Q
;
GP ;
F PSGP=0:0 S PSGP=$O(PSGPAT(PSGP)) Q:'PSGP D PAT
Q
;
PAT ;
S COST=0 D ^PSJAC S PSGPN=$S($P(PSGP(0),"^")]"":$P(PSGP(0),"^"),1:PSGP)_"^"_PSGP,PSN=$E($P(PSJPSSN,"^"),6,10)
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
S:$D(^TMP("PSG",$J,PSGPN)) ^(PSGPN)=$P(PSJPAD,"^",2)_"^"_PSN_"^"_PSJPDX Q
;
ADD ;
N X F X=0:0 S X=$O(^PS(55,PSGP,5,PSJJORD,1,X)) Q:'X D
.; naked ref below refers to line above
.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)
.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))
Q
;
G ;
S DIC="^PS(57.5,",DIC(0)="QEAMI",DIC("A")="Select WARD GROUP: " W ! D ^DIC K DIC S PSGWG=+Y Q
W ;
S DIC="^DIC(42,",DIC(0)="QEAMI",DIC("A")="Select WARD: " W ! D ^DIC K DIC S PSGWD=+Y Q
P ;
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
S Y=PSGPAT Q
;
DEV ;
K ZTSAVE S PSGTIR="ENQ^PSGTCTD",ZTDESC="TOTAL COST REPORT" F X="PSGSS","PSGWG","PSGWD","PSGPAT(" S ZTSAVE(X)=""
D ENDEV^PSGTI Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGTCTD 2065 printed Nov 22, 2024@17:13:26 Page 2
PSGTCTD ;BIR/CML3-SHOW TOTAL COST TO DATE OF PATIENTS ; 15 May 98 / 9:26 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**3,283**;16 DEC 97;Build 4
START ;
+1 DO ENCV^PSGSETU
IF '$DATA(XQUIT)
SET PSGSSH="TCR"
SET PSJACNWP=1
SET (PSGWG,PSGWD,PSGPAT)=0
DO NOCL^PSGSEL
IF "^"'[PSGSS
DO @PSGSS
IF +Y>0
DO DEV
IF 'POP
IF '$DATA(IO("Q"))
DO ENQ
DO ^%ZISC
+2 ;
DONE ;
+1 DO ENKV^PSGSETU
KILL AMT,CNTR,COST,DRG,DRGN,LN2,ND,PSJJORD,PSGDICA,PSGP,PSGPAT,PSGPN,PSGSS,PSGSSH,PSGWD,PSGWDN,PSGWG,PSN,SD,ZTOUT
QUIT
+2 ;
ENQ ;
+1 DO NOW^%DTC
SET PSGDT=%
SET DT=$PIECE(%,".")
KILL ^TMP("PSG",$JOB)
DO @("G"_PSGSS)
DO ^PSGTCTD0
+2 KILL ^TMP("PSG",$JOB)
QUIT
+3 ;
GG ;
+1 FOR PSGWD=0:0
SET PSGWD=$ORDER(^PS(57.5,"AC",PSGWG,PSGWD))
if 'PSGWD
QUIT
DO GW
+2 QUIT
+3 ;
GW ;
+1 IF $DATA(^DIC(42,PSGWD,0))
IF $PIECE(^(0),"^")]""
SET PSGWDN=$PIECE(^(0),"^")
FOR PSGP=0:0
SET PSGP=$ORDER(^DPT("CN",PSGWDN,PSGP))
if 'PSGP
QUIT
DO PAT
+2 QUIT
+3 ;
GP ;
+1 FOR PSGP=0:0
SET PSGP=$ORDER(PSGPAT(PSGP))
if 'PSGP
QUIT
DO PAT
+2 QUIT
+3 ;
PAT ;
+1 SET COST=0
DO ^PSJAC
SET PSGPN=$SELECT($PIECE(PSGP(0),"^")]"":$PIECE(PSGP(0),"^"),1:PSGP)_"^"_PSGP
SET PSN=$EXTRACT($PIECE(PSJPSSN,"^"),6,10)
+2 FOR SD=+PSJPAD:0
SET SD=$ORDER(^PS(55,PSGP,5,"AUS",SD))
if 'SD
QUIT
FOR PSJJORD=0:0
SET PSJJORD=$ORDER(^PS(55,PSGP,5,"AUS",SD,PSJJORD))
if 'PSJJORD
QUIT
DO ADD
+3 if $DATA(^TMP("PSG",$JOB,PSGPN))
SET ^(PSGPN)=$PIECE(PSJPAD,"^",2)_"^"_PSN_"^"_PSJPDX
QUIT
+4 ;
ADD ;
+1 NEW X
FOR X=0:0
SET X=$ORDER(^PS(55,PSGP,5,PSJJORD,1,X))
if 'X
QUIT
Begin DoDot:1
+2 ; naked ref below refers to line above
+3 SET ND=^(X,0)
SET DRG=+ND
SET DRGN=$GET(^PSDRUG(DRG,0))
SET DRGN=$SELECT($PIECE(DRGN,"^")]"":$PIECE(DRGN,"^"),1:DRG)_$SELECT('$PIECE(DRGN,"^",9):"",1:"^1")
SET DRG=+$PIECE($GET(^(660)),"^",6)
+4 SET AMT=$PIECE(ND,"^",6)+$PIECE(ND,"^",10)+$PIECE(ND,"^",12)-$PIECE(ND,"^",7)
IF DRG*AMT
SET ND=$GET(^TMP("PSG",$JOB,PSGPN,DRGN))
SET ^(DRGN)=+ND+AMT_"^"_(DRG*AMT+$PIECE(ND,"^",2))
End DoDot:1
+5 QUIT
+6 ;
G ;
+1 SET DIC="^PS(57.5,"
SET DIC(0)="QEAMI"
SET DIC("A")="Select WARD GROUP: "
WRITE !
DO ^DIC
KILL DIC
SET PSGWG=+Y
QUIT
W ;
+1 SET DIC="^DIC(42,"
SET DIC(0)="QEAMI"
SET DIC("A")="Select WARD: "
WRITE !
DO ^DIC
KILL DIC
SET PSGWD=+Y
QUIT
P ;
+1 KILL PSGPAT
SET PSGPAT=0
FOR CNTR=1:1
if CNTR>1
SET PSGDICA="another"
DO ENDPT^PSGP
if PSGP'>0
QUIT
SET PSGPAT(PSGP)=""
SET PSGPAT=PSGP
+2 SET Y=PSGPAT
QUIT
+3 ;
DEV ;
+1 KILL ZTSAVE
SET PSGTIR="ENQ^PSGTCTD"
SET ZTDESC="TOTAL COST REPORT"
FOR X="PSGSS","PSGWG","PSGWD","PSGPAT("
SET ZTSAVE(X)=""
+2 DO ENDEV^PSGTI
QUIT
