Routine: PSOCST6

PSOCST6 ;BHAM ISC/SAB - DRUG COSTS BY PATIENT STATUS ; 08/19/92 9:01

 ;;7.0;OUTPATIENT PHARMACY;**31**;DEC 1997

 ;External Ref. to ^PS(53, is supp. by DBIA# 1975

BEG S RP=6 D HDC^PSOCSTX F  D CDT^PSOCSTX Q:$G(CTR)  D PTS^PSOCSTX Q:$G(CTR)  S RP=0 D CTP^PSOCSTX Q:$G(CTR)  I RP=0 D DEV Q

 D EX Q

DEV D DVC^PSOCSTX Q:$G(CTR)

 K PSOION I $D(IO("Q")) S ZTDESC="DRUG COST BY PATIENT STATUS",ZTRTN="START^PSOCST6" D PAS^PSOCSTX

 I  K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"REPORT QUEUED TO PRINT !!",! D EX Q

START U IO K ^TMP($J) F PSDT=(BEGDATE-1):0:ENDDATE S PSDT=$O(^PSCST(PSDT)) Q:'PSDT!(PSDT>ENDDATE)  D @$S('IFN:"PAT",1:"STA")

 D ZER^PSOCSTX S STAX="" D HD I $O(^TMP($J,STAX))']"" D HDN^PSOCSTX Q

 F I=0:0 S STAX=$O(^TMP($J,STAX)) Q:STAX=""  D HD:($Y+4)>IOSL Q:$G(CTR)  D

 .S Y=^TMP($J,STAX),TTX=STAX D PRT^PSOCSTX

 I 'CTR,'IFN D HD:($Y+2)>IOSL D FTX^PSOCSTX

EX D EX^PSOCSTX Q

PAT F STA=0:0 S STA=$O(^PSCST(PSDT,"PS",STA)) Q:'STA  D STA

STA I $D(^PSCST(PSDT,"PS",STA,0)) S X=^(0) D STORE

STORE Q:'$D(^PS(53,STA,0))  S STAX=$P(^(0),"^") S:'$D(^TMP($J,STAX)) ^TMP($J,STAX)="^0^0^0"

 S UTL=^TMP($J,STAX),^TMP($J,STAX)="^"_($P(UTL,"^",2)+$P(X,"^",2))_"^"_($P(UTL,"^",3)+$P(X,"^",3))_"^"_($P(UTL,"^",4)+$P(X,"^",4))

HD D HD^PSOCSTX Q

PSOCST6   ;BHAM ISC/SAB - DRUG COSTS BY PATIENT STATUS ; 08/19/92 9:01

 +1       ;;7.0;OUTPATIENT PHARMACY;**31**;DEC 1997

 +2       ;External Ref. to ^PS(53, is supp. by DBIA# 1975

BEG        SET RP=6

           DO HDC^PSOCSTX

FOR

               DO CDT^PSOCSTX

               IF $GET(CTR)

                   QUIT

               DO PTS^PSOCSTX

               IF $GET(CTR)

                   QUIT

               SET RP=0

               DO CTP^PSOCSTX

               IF $GET(CTR)

                   QUIT

               IF RP=0

                   DO DEV

                   QUIT

 +1        DO EX

           QUIT

DEV        DO DVC^PSOCSTX

           IF $GET(CTR)

               QUIT

 +1        KILL PSOION

           IF $DATA(IO("Q"))

               SET ZTDESC="DRUG COST BY PATIENT STATUS"

               SET ZTRTN="START^PSOCST6"

               DO PAS^PSOCSTX

 +2       IF $TEST

               KILL IO("Q")

               DO ^%ZTLOAD

               IF $DATA(ZTSK)

                   WRITE !,"REPORT QUEUED TO PRINT !!",!

               DO EX

               QUIT

START      USE IO

           KILL ^TMP($JOB)

           FOR PSDT=(BEGDATE-1):0:ENDDATE

               SET PSDT=$ORDER(^PSCST(PSDT))

               IF 'PSDT!(PSDT>ENDDATE)

                   QUIT

               DO @$SELECT('IFN:"PAT",1:"STA")

 +1        DO ZER^PSOCSTX

           SET STAX=""

           DO HD

           IF $ORDER(^TMP($JOB,STAX))']""

               DO HDN^PSOCSTX

               QUIT

 +2        FOR I=0:0

               SET STAX=$ORDER(^TMP($JOB,STAX))

               IF STAX=""

                   QUIT

               IF ($Y+4)>IOSL

                   DO HD

               IF $GET(CTR)

                   QUIT

               Begin DoDot:1

 +3                SET Y=^TMP($JOB,STAX)

                   SET TTX=STAX

                   DO PRT^PSOCSTX

               End DoDot:1

 +4        IF 'CTR

               IF 'IFN

                   IF ($Y+2)>IOSL

                       DO HD

                   DO FTX^PSOCSTX

EX         DO EX^PSOCSTX

           QUIT

PAT        FOR STA=0:0

               SET STA=$ORDER(^PSCST(PSDT,"PS",STA))

               IF 'STA

                   QUIT

               DO STA

 +1        QUIT

STA        IF $DATA(^PSCST(PSDT,"PS",STA,0))

               SET X=^(0)

               DO STORE

 +1        QUIT

STORE      IF '$DATA(^PS(53,STA,0))

               QUIT

           SET STAX=$PIECE(^(0),"^")

           IF '$DATA(^TMP($JOB,STAX))

               SET ^TMP($JOB,STAX)="^0^0^0"

 +1        SET UTL=^TMP($JOB,STAX)

           SET ^TMP($JOB,STAX)="^"_($PIECE(UTL,"^",2)+$PIECE(X,"^",2))_"^"_($PIECE(UTL,"^",3)+$PIECE(X,"^",3))_"^"_($PIECE(UTL,"^",4)+$PIECE(X,"^",4))

 +2        QUIT

HD         DO HD^PSOCSTX

           QUIT

PSOCST6.m