- PSGTCTD ;BIR/CML3-SHOW TOTAL COST TO DATE OF PATIENTS ; 15 May 98 / 9:26 AM
- ;;5.0; INPATIENT MEDICATIONS ;**3**;16 DEC 97
- START ;
- 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
- ;
- 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
- PSGTCTD ;BIR/CML3-SHOW TOTAL COST TO DATE OF PATIENTS ; 15 May 98 / 9:26 AM
- +1 ;;5.0; INPATIENT MEDICATIONS ;**3**;16 DEC 97
- START ;
- +1 DO ENCV^PSGSETU
- IF '$DATA(XQUIT)
- SET PSGSSH="TCR"
- SET PSJACNWP=1
- SET (PSGWG,PSGWD,PSGPAT)=0
- DO ^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
