source: FOIAVistA/trunk/r/CMOP-PSX/PSXSUDCN.m@ 686

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