PSXSUDCN.m

PSXSUDCN ;BIR/HTW-Routine to Provide Report of Rx's Suspended for CMOP ; 31 Oct 2000  1:20 PM

 ;;2.0;CMOP;**31**;11 Apr 97

 ; External reference to ^PS(52.5 supported by DBIA #1222

 ; External reference to ^PS(59 supported by DBIA #1976

 ;

BEGDATE ;GET BEGIN DATE

 K DIR

 W !,"Rx's Suspended for CMOP",!

 S DIR(0)="DO",DIR("A")="ENTER BEGINNING DATE " D ^DIR K DIR

 G:($G(Y)="")!($D(DIRUT)) END1

 S PSXB=Y

ENDDATE ;GET ENDING DATE

 K DIR,X,Y

 S Y=DT X ^DD("DD") S DIR("B")=Y

 S DIR(0)="DO",DIR("A")="ENTER ENDING DATE" D ^DIR K DIR

 I $G(Y)="" G BEGDATE

 Q:$D(DTOUT)  I $D(DUOUT) G BEGDATE

 S PSXE=Y

 I PSXE<PSXB W !,"Ending date must follow beginning date!" G ENDDATE

 ; select division(s)

 D SEL

 I '$D(DIVNM) D END1,EXIT Q

 ;

DEVICE W !! S %ZIS="MQ",%ZIS("A")="Select Printer: ",%ZIS("B")=""

 D ^%ZIS G:POP END1 S PSXLAP=ION

 I IOST["C-" G EN1

 I '$D(IO("Q")) G EN0

QUE S ZTSAVE("PSXB")="",ZTSAVE("PSXE")="",ZTSAVE("DIVDA(")="",ZTSAVE("DIVNM(")="",ZTIO=PSXLAP

 S ZTRTN="EN1^PSXSUDCN"

 S ZTDESC="CMOP Count of Suspended CMOP Rx's by Day"

 D ^%ZTLOAD

Q1 W:$D(ZTSK) !!,"Report Queued to Print!! ",ZTSK,!

 K DIR,PSXB,PSXE,Y D ^%ZISC

 D EXIT

 Q

EN0 U IO

 ;Called by Taskman to run CMOP Rx's by day report

EN1 ;

 S:$D(ZTQUEUED) ZTREQ="@"

DIVISION ;

 S DIV=0 F  Q:$G(PSXFLAG)=1  S DIV=$O(DIVDA(DIV)) Q:DIV'>0  D ONEDIV

 D GRNDSUM

 G EXIT

 ;

ONEDIV ;

 S LINE="W ! F I=1:1:80 W ""=""",CT=0

 S Y=PSXB X ^DD("DD") S PSXBE=Y

 S Y=PSXE X ^DD("DD") S PSXEE=Y

 S (PSXQ,PSXL,PSXAX,PSXP,PSXTOT)=0

 S PSXD=PSXB-.00001,PSXTE=PSXE+.99999

 D HEADER S CT=8

 F  Q:$G(PSXFLAG)=1  S PSXD=$O(^PS(52.5,"C",PSXD)) Q:'PSXD!(PSXD>PSXTE)  D 525,BODY Q:$G(ANS)="^"

 G END

525 Q:$G(PSXFLAG)=1

 F PSX525=0:0 Q:$G(PSXFLAG)=1  S PSX525=$O(^PS(52.5,"C",PSXD,PSX525)) Q:'PSX525  I $D(^PS(52.5,PSX525,0)) D

 .S DIVRX=$P(^PS(52.5,PSX525,0),U,6) Q:DIVRX'=DIV

 .S N=$P($G(^PS(52.5,PSX525,0)),"^",7) I N]"" D

 ..S:N="Q" PSXQ=PSXQ+1

 ..I N="L"!(N="X")!(N="R") S PSXAX=PSXAX+1

 ..S:N="P" PSXP=PSXP+1

 ..S PSXTOT=PSXTOT+1

 Q

HEADER D NOW^%DTC S Y=% X ^DD("DD") S PSXNOW=Y

HDR1 I IOST["C-" W @IOF

 W !,?20,"COUNT OF SUSPENDED CMOP RX's BY DAY"

 W !,DIVDA(DIV)

 W !,"FROM: "_PSXBE,"  TO: "_$P(PSXEE,"@"),"   PRINTED: ",PSXNOW

 X LINE

H1 W !,"DATE",?14,"QUEUED",?29,"TRANSMITTED",?47,"PRINTED",?62,"TOTAL"

 S A=15-($L($G(PSXQ))\2),B=35-($L($G(PSXAX))\2),C=49-($L($G(PSXP))\2),D=62-($L($G(PSXTOT))\2)

 X LINE

 Q

BODY ;

 Q:$G(PSXFLAG)=1

 I IOST["C-",(CT>20) D PAGE Q:$G(ANS)="^"  W @IOF S CT=0 D HDR1 G B1

 I $G(CT)>56 S CT=0 W @IOF D HEADER

B1 S Y=PSXD X ^DD("DD") S XDATE=$P(Y,","),CT=CT+1

 W !,XDATE,?A,$J($G(PSXQ),5),?B,$J($G(PSXAX),5),?C,$J($G(PSXP),5),?D,$J($G(PSXTOT),5)

 S PSXQGD=$G(PSXQGD)+PSXQ,PSXAXGD=$G(PSXAXGD)+PSXAX,PSXPGD=$G(PSXPGD)+PSXP,PSXTOTGD=$G(PSXTOTGD)+PSXTOT

 S (PSXQ,PSXAX,PSXP,PSXTOT)=0 K XDATE

 Q

PAGE Q:$G(PSXFLAG)=1

 K DIR S DIR(0)="FO",DIR("A")="Press RETURN to continue or ""^"" to exit" D ^DIR S:$D(DTOUT)!($D(DUOUT)) (ANS)="^",PSXFLAG=1

 Q

END Q:$G(PSXFLAG)=1

 X LINE W !,"Division Total",?A,$J($G(PSXQGD),5),?B,$J($G(PSXAXGD),5),?C,$J($G(PSXPGD),5),?D,$J($G(PSXTOTGD),5)

 F X="PSXQGD","PSXAXGD","PSXPGD","PSXTOTGD" S DIVTOT(DIV,X)=$G(@X)

 I IOST["C-" D PAGE

 I IOST'["C-" W @IOF

END1 K DIR,X,Y,%,PSXD,PSXF,PSXQ,PSXL,PSXP,PSXAX,PSXTOT,PSXUNREL

 K PSXAD,PSXOT,PSXR,I,PSXZ,FILL,STAT,NODE,POP,PSXGO

 K PSXLAP,PSXNOW,PSXYES,ZTDESC,ZTIO,ZTRTN,ZTSAVE,PSXMW,PSXM,PSXW

 K A,B,D,E,PSXCR,PSXCU,PSXFILL,PSXSUSDT,PSXX,ZTSK

 K N,PSX525,PSXMT,PSXWT,C,CT,DIRUT,DIROUT,DTOUT,DUOUT,J,ANS,PSXQGD,PSXAXGD,PSXPGD,PSXTOTGD

 Q

EXIT ;

 D ^%ZISC

 K PSXB,PSXE,LINE,PSXBE,PSXEE,PSXTE,DIVNM,DIVDA,DIV,DIVRX,DIVTOT,PSXFLAG         D END1

 Q

SEL ;Select divisions

 ; returns arrays

 ; DIVNM("names of divisions")=selection number

 ; DIVDA("iens of divisions")=name of division

 ; for testing

 W !!,"SELECTION OF DIVISION(S)",!

 S DIV="" K DIVNM,DIVDA,DIVX

 F I=1:1 S DIV=$O(^PS(59,"B",DIV)) Q:DIV=""  S DIVNM(I)=DIV,DIVNM(DIV)=I,DIVDA=$O(^PS(59,"B",DIV,0)),DIVNM(I,"I")=DIVDA

 S I=I-1

 K DIR S DIR(0)="S^A:ALL DIVISIONS;S:SELECT DIVISIONS"

 D ^DIR K DIR

 G:Y="A" ALL

 G:Y="S" SELECT

 Q

SELECT ;

 F C=1:1:I S DIR("A",C)=C_"    "_DIVNM(C)

 S DIR(0)="LO^1:"_I,DIR("A")="Select Division(s) "

 D ^DIR

 I '+Y K DIVNM Q

 M DIVX=DIVNM K DIVNM

 F I=1:1 S X=$P(Y,",",I) Q:'X  M DIVNM(X)=DIVX(X) S DIVNM=DIVX(X),DIVNM(DIVNM)=X

 K DIVX,DIR

ALL W !!,"You have selected:",! S DIV=0 F  S DIV=$O(DIVNM(DIV)) Q:'DIV  W !,DIV,?5,DIVNM(DIV)

 S DIR(0)="Y",DIR("A")="Is this corrrect ? ",DIR("B")="YES" D ^DIR

 K DIR

 I Y D  Q

 .K DIVDA

 .S DIV=0 F  S DIV=$O(DIVNM(DIV)) Q:'DIV  S DA=DIVNM(DIV,"I"),DIVDA(DA)=DIVNM(DIV) K DIVNM(DIV)

 G SEL

 ;

GRNDSUM ;

 Q:$G(PSXFLAG)=1

 S DIV=0,DIVDA(0)="                            GRAND TOTAL SUMMARY"

 D HEADER

 K DIVTOT(0)

 F  S DIV=$O(DIVDA(DIV)) Q:DIV'>0  D

 . W !,DIVDA(DIV)

 . F X="PSXQGD","PSXAXGD","PSXPGD","PSXTOTGD" S @X=DIVTOT(DIV,X),DIVTOT(0,X)=$G(DIVTOT(0,X))+@X

 . W !,?A,$J($G(PSXQGD),5),?B,$J($G(PSXAXGD),5),?C,$J($G(PSXPGD),5),?D,$J($G(PSXTOTGD),5)

 F X="PSXQGD","PSXAXGD","PSXPGD","PSXTOTGD" S @X=DIVTOT(0,X)

 X LINE

 W !,"Grand Total",?A,$J($G(PSXQGD),5),?B,$J($G(PSXAXGD),5),?C,$J($G(PSXPGD),5),?D,$J($G(PSXTOTGD),5)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSXSUDCN   5252     printed  Feb 18, 2025@23:11:41                                                                                                                                                                                                    Page 2

PSXSUDCN  ;BIR/HTW-Routine to Provide Report of Rx's Suspended for CMOP ; 31 Oct 2000  1:20 PM

 +1       ;;2.0;CMOP;**31**;11 Apr 97

 +2       ; External reference to ^PS(52.5 supported by DBIA #1222

 +3       ; External reference to ^PS(59 supported by DBIA #1976

 +4       ;

BEGDATE   ;GET BEGIN DATE

 +1        KILL DIR

 +2        WRITE !,"Rx's Suspended for CMOP",!

 +3        SET DIR(0)="DO"

           SET DIR("A")="ENTER BEGINNING DATE "

           DO ^DIR

           KILL DIR

 +4        if ($GET(Y)="")!($DATA(DIRUT))

               GOTO END1

 +5        SET PSXB=Y

ENDDATE   ;GET ENDING DATE

 +1        KILL DIR,X,Y

 +2        SET Y=DT

           XECUTE ^DD("DD")

           SET DIR("B")=Y

 +3        SET DIR(0)="DO"

           SET DIR("A")="ENTER ENDING DATE"

           DO ^DIR

           KILL DIR

 +4        IF $GET(Y)=""

               GOTO BEGDATE

 +5        if $DATA(DTOUT)

               QUIT 

           IF $DATA(DUOUT)

               GOTO BEGDATE

 +6        SET PSXE=Y

 +7        IF PSXE<PSXB

               WRITE !,"Ending date must follow beginning date!"

               GOTO ENDDATE

 +8       ; select division(s)

 +9        DO SEL

 +10       IF '$DATA(DIVNM)

               DO END1

               DO EXIT

               QUIT 

 +11      ;

DEVICE     WRITE !!

           SET %ZIS="MQ"

           SET %ZIS("A")="Select Printer: "

           SET %ZIS("B")=""

 +1        DO ^%ZIS

           if POP

               GOTO END1

           SET PSXLAP=ION

 +2        IF IOST["C-"

               GOTO EN1

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

               GOTO EN0

QUE        SET ZTSAVE("PSXB")=""

           SET ZTSAVE("PSXE")=""

           SET ZTSAVE("DIVDA(")=""

           SET ZTSAVE("DIVNM(")=""

           SET ZTIO=PSXLAP

 +1        SET ZTRTN="EN1^PSXSUDCN"

 +2        SET ZTDESC="CMOP Count of Suspended CMOP Rx's by Day"

 +3        DO ^%ZTLOAD

Q1         if $DATA(ZTSK)

               WRITE !!,"Report Queued to Print!! ",ZTSK,!

 +1        KILL DIR,PSXB,PSXE,Y

           DO ^%ZISC

 +2        DO EXIT

 +3        QUIT 

EN0        USE IO

 +1       ;Called by Taskman to run CMOP Rx's by day report

EN1       ;

 +1        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

DIVISION  ;

 +1        SET DIV=0

           FOR 

               if $GET(PSXFLAG)=1

                   QUIT 

               SET DIV=$ORDER(DIVDA(DIV))

               if DIV'>0

                   QUIT 

               DO ONEDIV

 +2        DO GRNDSUM

 +3        GOTO EXIT

 +4       ;

ONEDIV    ;

 +1        SET LINE="W ! F I=1:1:80 W ""="""

           SET CT=0

 +2        SET Y=PSXB

           XECUTE ^DD("DD")

           SET PSXBE=Y

 +3        SET Y=PSXE

           XECUTE ^DD("DD")

           SET PSXEE=Y

 +4        SET (PSXQ,PSXL,PSXAX,PSXP,PSXTOT)=0

 +5        SET PSXD=PSXB-.00001

           SET PSXTE=PSXE+.99999

 +6        DO HEADER

           SET CT=8

 +7        FOR 

               if $GET(PSXFLAG)=1

                   QUIT 

               SET PSXD=$ORDER(^PS(52.5,"C",PSXD))

               if 'PSXD!(PSXD>PSXTE)

                   QUIT 

               DO 525

               DO BODY

               if $GET(ANS)="^"

                   QUIT 

 +8        GOTO END

525        if $GET(PSXFLAG)=1

               QUIT 

 +1        FOR PSX525=0:0

               if $GET(PSXFLAG)=1

                   QUIT 

               SET PSX525=$ORDER(^PS(52.5,"C",PSXD,PSX525))

               if 'PSX525

                   QUIT 

               IF $DATA(^PS(52.5,PSX525,0))

                   Begin DoDot:1

 +2                    SET DIVRX=$PIECE(^PS(52.5,PSX525,0),U,6)

                       if DIVRX'=DIV

                           QUIT 

 +3                    SET N=$PIECE($GET(^PS(52.5,PSX525,0)),"^",7)

                       IF N]""

                           Begin DoDot:2

 +4                            if N="Q"

                                   SET PSXQ=PSXQ+1

 +5                            IF N="L"!(N="X")!(N="R")

                                   SET PSXAX=PSXAX+1

 +6                            if N="P"

                                   SET PSXP=PSXP+1

 +7                            SET PSXTOT=PSXTOT+1

                           End DoDot:2

                   End DoDot:1

 +8        QUIT 

HEADER     DO NOW^%DTC

           SET Y=%

           XECUTE ^DD("DD")

           SET PSXNOW=Y

HDR1       IF IOST["C-"

               WRITE @IOF

 +1        WRITE !,?20,"COUNT OF SUSPENDED CMOP RX's BY DAY"

 +2        WRITE !,DIVDA(DIV)

 +3        WRITE !,"FROM: "_PSXBE,"  TO: "_$PIECE(PSXEE,"@"),"   PRINTED: ",PSXNOW

 +4        XECUTE LINE

H1         WRITE !,"DATE",?14,"QUEUED",?29,"TRANSMITTED",?47,"PRINTED",?62,"TOTAL"

 +1        SET A=15-($LENGTH($GET(PSXQ))\2)

           SET B=35-($LENGTH($GET(PSXAX))\2)

           SET C=49-($LENGTH($GET(PSXP))\2)

           SET D=62-($LENGTH($GET(PSXTOT))\2)

 +2        XECUTE LINE

 +3        QUIT 

BODY      ;

 +1        if $GET(PSXFLAG)=1

               QUIT 

 +2        IF IOST["C-"

               IF (CT>20)

                   DO PAGE

                   if $GET(ANS)="^"

                       QUIT 

                   WRITE @IOF

                   SET CT=0

                   DO HDR1

                   GOTO B1

 +3        IF $GET(CT)>56

               SET CT=0

               WRITE @IOF

               DO HEADER

B1         SET Y=PSXD

           XECUTE ^DD("DD")

           SET XDATE=$PIECE(Y,",")

           SET CT=CT+1

 +1        WRITE !,XDATE,?A,$JUSTIFY($GET(PSXQ),5),?B,$JUSTIFY($GET(PSXAX),5),?C,$JUSTIFY($GET(PSXP),5),?D,$JUSTIFY($GET(PSXTOT),5)

 +2        SET PSXQGD=$GET(PSXQGD)+PSXQ

           SET PSXAXGD=$GET(PSXAXGD)+PSXAX

           SET PSXPGD=$GET(PSXPGD)+PSXP

           SET PSXTOTGD=$GET(PSXTOTGD)+PSXTOT

 +3        SET (PSXQ,PSXAX,PSXP,PSXTOT)=0

           KILL XDATE

 +4        QUIT 

PAGE       if $GET(PSXFLAG)=1

               QUIT 

 +1        KILL DIR

           SET DIR(0)="FO"

           SET DIR("A")="Press RETURN to continue or ""^"" to exit"

           DO ^DIR

           if $DATA(DTOUT)!($DATA(DUOUT))

               SET (ANS)="^"

               SET PSXFLAG=1

 +2        QUIT 

END        if $GET(PSXFLAG)=1

               QUIT 

 +1        XECUTE LINE

           WRITE !,"Division Total",?A,$JUSTIFY($GET(PSXQGD),5),?B,$JUSTIFY($GET(PSXAXGD),5),?C,$JUSTIFY($GET(PSXPGD),5),?D,$JUSTIFY($GET(PSXTOTGD),5)

 +2        FOR X="PSXQGD","PSXAXGD","PSXPGD","PSXTOTGD"

               SET DIVTOT(DIV,X)=$GET(@X)

 +3        IF IOST["C-"

               DO PAGE

 +4        IF IOST'["C-"

               WRITE @IOF

END1       KILL DIR,X,Y,%,PSXD,PSXF,PSXQ,PSXL,PSXP,PSXAX,PSXTOT,PSXUNREL

 +1        KILL PSXAD,PSXOT,PSXR,I,PSXZ,FILL,STAT,NODE,POP,PSXGO

 +2        KILL PSXLAP,PSXNOW,PSXYES,ZTDESC,ZTIO,ZTRTN,ZTSAVE,PSXMW,PSXM,PSXW

 +3        KILL A,B,D,E,PSXCR,PSXCU,PSXFILL,PSXSUSDT,PSXX,ZTSK

 +4        KILL N,PSX525,PSXMT,PSXWT,C,CT,DIRUT,DIROUT,DTOUT,DUOUT,J,ANS,PSXQGD,PSXAXGD,PSXPGD,PSXTOTGD

 +5        QUIT 

EXIT      ;

 +1        DO ^%ZISC

 +2        KILL PSXB,PSXE,LINE,PSXBE,PSXEE,PSXTE,DIVNM,DIVDA,DIV,DIVRX,DIVTOT,PSXFLAG

           DO END1

 +3        QUIT 

SEL       ;Select divisions

 +1       ; returns arrays

 +2       ; DIVNM("names of divisions")=selection number

 +3       ; DIVDA("iens of divisions")=name of division

 +4       ; for testing

 +5        WRITE !!,"SELECTION OF DIVISION(S)",!

 +6        SET DIV=""

           KILL DIVNM,DIVDA,DIVX

 +7        FOR I=1:1

               SET DIV=$ORDER(^PS(59,"B",DIV))

               if DIV=""

                   QUIT 

               SET DIVNM(I)=DIV

               SET DIVNM(DIV)=I

               SET DIVDA=$ORDER(^PS(59,"B",DIV,0))

               SET DIVNM(I,"I")=DIVDA

 +8        SET I=I-1

 +9        KILL DIR

           SET DIR(0)="S^A:ALL DIVISIONS;S:SELECT DIVISIONS"

 +10       DO ^DIR

           KILL DIR

 +11       if Y="A"

               GOTO ALL

 +12       if Y="S"

               GOTO SELECT

 +13       QUIT 

SELECT    ;

 +1        FOR C=1:1:I

               SET DIR("A",C)=C_"    "_DIVNM(C)

 +2        SET DIR(0)="LO^1:"_I

           SET DIR("A")="Select Division(s) "

 +3        DO ^DIR

 +4        IF '+Y

               KILL DIVNM

               QUIT 

 +5        MERGE DIVX=DIVNM

           KILL DIVNM

 +6        FOR I=1:1

               SET X=$PIECE(Y,",",I)

               if 'X

                   QUIT 

               MERGE DIVNM(X)=DIVX(X)

               SET DIVNM=DIVX(X)

               SET DIVNM(DIVNM)=X

 +7        KILL DIVX,DIR

ALL        WRITE !!,"You have selected:",!

           SET DIV=0

           FOR 

               SET DIV=$ORDER(DIVNM(DIV))

               if 'DIV

                   QUIT 

               WRITE !,DIV,?5,DIVNM(DIV)

 +1        SET DIR(0)="Y"

           SET DIR("A")="Is this corrrect ? "

           SET DIR("B")="YES"

           DO ^DIR

 +2        KILL DIR

 +3        IF Y

               Begin DoDot:1

 +4                KILL DIVDA

 +5                SET DIV=0

                   FOR 

                       SET DIV=$ORDER(DIVNM(DIV))

                       if 'DIV

                           QUIT 

                       SET DA=DIVNM(DIV,"I")

                       SET DIVDA(DA)=DIVNM(DIV)

                       KILL DIVNM(DIV)

               End DoDot:1

               QUIT 

 +6        GOTO SEL

 +7       ;

GRNDSUM   ;

 +1        if $GET(PSXFLAG)=1

               QUIT 

 +2        SET DIV=0

           SET DIVDA(0)="                            GRAND TOTAL SUMMARY"

 +3        DO HEADER

 +4        KILL DIVTOT(0)

 +5        FOR 

               SET DIV=$ORDER(DIVDA(DIV))

               if DIV'>0

                   QUIT 

               Begin DoDot:1

 +6                WRITE !,DIVDA(DIV)

 +7                FOR X="PSXQGD","PSXAXGD","PSXPGD","PSXTOTGD"

                       SET @X=DIVTOT(DIV,X)

                       SET DIVTOT(0,X)=$GET(DIVTOT(0,X))+@X

 +8                WRITE !,?A,$JUSTIFY($GET(PSXQGD),5),?B,$JUSTIFY($GET(PSXAXGD),5),?C,$JUSTIFY($GET(PSXPGD),5),?D,$JUSTIFY($GET(PSXTOTGD),5)

               End DoDot:1

 +9        FOR X="PSXQGD","PSXAXGD","PSXPGD","PSXTOTGD"

               SET @X=DIVTOT(0,X)

 +10       XECUTE LINE

 +11       WRITE !,"Grand Total",?A,$JUSTIFY($GET(PSXQGD),5),?B,$JUSTIFY($GET(PSXAXGD),5),?C,$JUSTIFY($GET(PSXPGD),5),?D,$JUSTIFY($GET(PSXTOTGD),5)

 +12       QUIT