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
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 ---[H[J[2J[HPSXSUDCN 5252 printed Apr 09, 2024@20:50:44 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
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
