PSGSCT.m

PSGSCT ;BIR/CML3-SERVICE COST TOTALS ; 22 Jun 98 / 1:50 PM

 ;;5.0; INPATIENT MEDICATIONS ;**3,12**;16 DEC 97

 ;

 D ENCV^PSGSETU I '$D(XQUIT) S HLP="SERVICE" D ENDTS^PSGAMS I SD,FD S ZTDESC="COST PER SERVICE REPORT",RTN="SCT" D EN3^PSGTI I 'POP,'$D(IO("Q")) D ENQ D:IO'=IO(0)!($E(IOST)'="C") ^%ZISC

 ;

DONE ;

 D ENKV^PSGSETU K COST,DRG,FD,HLP,RTN,ND,NU,P,PR,SD,ST,STOP,STRT,W,WN,WD Q

 ;

ENQ ;

 K ^UTILITY("PSG",$J) F ST=SD:0 S ST=$O(^PS(57.6,ST)) Q:'ST!(ST>FD)  S W=0 F  S W=$O(^PS(57.6,ST,1,W)) Q:'W  S (CNT,COST)=0,(SN,WD)="" D ADD

 D ^PSGSCT0 K ^UTILITY("PSG",$J) Q

 ;

ADD ; find service, if possible, or ward name

 S SN=$P($G(^DIC(42,W,0)),"^",3) I SN]"",$$VFIELD^DILFD(42,.03) S SN=$$EXTERNAL^DILFD(42,.03,"",SN) G:SN]"" DRG

 S WD=$S('$D(^DIC(42,W,0)):W,$P(^(0),"^")]"":$P(^(0),"^"),1:W)

DRG ;

 S PR=0 F  S PR=$O(^PS(57.6,ST,1,W,1,PR)) Q:'PR  S DRG=0 F  S DRG=$O(^PS(57.6,ST,1,W,1,PR,1,DRG)) Q:'DRG  I $D(^(DRG,0)) S ND=^(0),CNT=CNT+$P(ND,"^",2)-$P(ND,"^",4),COST=COST+$P(ND,"^",3)-$P(ND,"^",5)

 Q:'CNT&'COST

 ;

TOT ; set global of service, if service found, or ward if service not found

 I SN]"" S ND=$G(^UTILITY("PSG",$J,"S",SN)),^(SN)=+ND+CNT_"^"_($P(ND,"^",2)+COST) Q

 S ND=$G(^UTILITY("PSG",$J,"W",WD)),^(WD)=+ND+CNT_"^"_($P(ND,"^",2)+COST) Q

PSGSCT    ;BIR/CML3-SERVICE COST TOTALS ; 22 Jun 98 / 1:50 PM

 +1       ;;5.0; INPATIENT MEDICATIONS ;**3,12**;16 DEC 97

 +2       ;

 +3        DO ENCV^PSGSETU

           IF '$DATA(XQUIT)

               SET HLP="SERVICE"

               DO ENDTS^PSGAMS

               IF SD

                   IF FD

                       SET ZTDESC="COST PER SERVICE REPORT"

                       SET RTN="SCT"

                       DO EN3^PSGTI

                       IF 'POP

                           IF '$DATA(IO("Q"))

                               DO ENQ

                               IF IO'=IO(0)!($EXTRACT(IOST)'="C")

                                   DO ^%ZISC

 +4       ;

DONE      ;

 +1        DO ENKV^PSGSETU

           KILL COST,DRG,FD,HLP,RTN,ND,NU,P,PR,SD,ST,STOP,STRT,W,WN,WD

           QUIT 

 +2       ;

ENQ       ;

 +1        KILL ^UTILITY("PSG",$JOB)

           FOR ST=SD:0

               SET ST=$ORDER(^PS(57.6,ST))

               IF 'ST!(ST>FD)

                   QUIT 

               SET W=0

               FOR 

                   SET W=$ORDER(^PS(57.6,ST,1,W))

                   IF 'W

                       QUIT 

                   SET (CNT,COST)=0

                   SET (SN,WD)=""

                   DO ADD

 +2        DO ^PSGSCT0

           KILL ^UTILITY("PSG",$JOB)

           QUIT 

 +3       ;

ADD       ; find service, if possible, or ward name

 +1        SET SN=$PIECE($GET(^DIC(42,W,0)),"^",3)

           IF SN]""

               IF $$VFIELD^DILFD(42,.03)

                   SET SN=$$EXTERNAL^DILFD(42,.03,"",SN)

                   IF SN]""

                       GOTO DRG

 +2        SET WD=$SELECT('$DATA(^DIC(42,W,0)):W,$PIECE(^(0),"^")]"":$PIECE(^(0),"^"),1:W)

DRG       ;

 +1        SET PR=0

           FOR 

               SET PR=$ORDER(^PS(57.6,ST,1,W,1,PR))

               IF 'PR

                   QUIT 

               SET DRG=0

               FOR 

                   SET DRG=$ORDER(^PS(57.6,ST,1,W,1,PR,1,DRG))

                   IF 'DRG

                       QUIT 

                   IF $DATA(^(DRG,0))

                       SET ND=^(0)

                       SET CNT=CNT+$PIECE(ND,"^",2)-$PIECE(ND,"^",4)

                       SET COST=COST+$PIECE(ND,"^",3)-$PIECE(ND,"^",5)

 +2        IF 'CNT&'COST

               QUIT 

 +3       ;

TOT       ; set global of service, if service found, or ward if service not found

 +1        IF SN]""

               SET ND=$GET(^UTILITY("PSG",$JOB,"S",SN))

               SET ^(SN)=+ND+CNT_"^"_($PIECE(ND,"^",2)+COST)

               QUIT 

 +2        SET ND=$GET(^UTILITY("PSG",$JOB,"W",WD))

           SET ^(WD)=+ND+CNT_"^"_($PIECE(ND,"^",2)+COST)

           QUIT