1 | ORPKFIX ;HISC/JFR - FIX BAD PACKAGE POINTERS IN ^OR(100 11/7/95 10:00
|
---|
2 | ;;2.5;ORDER ENTRY/RESULTS REPORTING;**37,44**;Jan 08, 1993
|
---|
3 | ; This routine will repoint any orders in file 100 that have a
|
---|
4 | ; different package associated with the order than the protocol
|
---|
5 | ; that created the order.
|
---|
6 | EN D DT^DICRW
|
---|
7 | I $D(^TMP("ORPKFIX")) D
|
---|
8 | .W !!,"It appears you may have errored out running this patch before."
|
---|
9 | .W !,"Your count of records corrected will be off but all corrections "
|
---|
10 | .W !,"will be shown if you print the report."
|
---|
11 | .W !! H 2
|
---|
12 | W !,"I'll check your ORDER file for bad PACKAGE file pointers.",!
|
---|
13 | S (ORCNT,ORREC,ORRECNT)=0 F S ORREC=$O(^OR(100,ORREC)) Q:'ORREC D
|
---|
14 | .S ORRECNT=ORRECNT+1 W:'(ORRECNT#1000) "."
|
---|
15 | .S ORPROT=$P($G(^OR(100,ORREC,0)),"^",5) Q:ORPROT'["ORD"
|
---|
16 | .S ORPROTPK=$P($G(^ORD(101,+ORPROT,0)),"^",12),ORDPK=$P($G(^OR(100,ORREC,0)),"^",14)
|
---|
17 | .Q:$G(^OR(100,ORREC,1,1,0))["DC"
|
---|
18 | .I ORPROTPK'=ORDPK D Q
|
---|
19 | ..S ORCNT=ORCNT+1
|
---|
20 | ..S $P(^OR(100,ORREC,0),"^",14)=ORPROTPK
|
---|
21 | ..S X=ORDPK S DIC="^DIC(9.4,",DIC(0)="XN" D ^DIC S ORDPK=$P(Y,"^",2)
|
---|
22 | ..S X=ORPROTPK S DIC="^DIC(9.4,",DIC(0)="XN" D ^DIC S ORPROTPK=$P(Y,"^",2)
|
---|
23 | ..S ^TMP("ORPKFIX",$J,ORREC)=ORREC_"^"_ORDPK_"^"_ORPROTPK
|
---|
24 | W !!,"Finished"
|
---|
25 | W !!,ORCNT," Orders have been fixed."
|
---|
26 | K DIC,ORDPK,ORPROT,ORPROTPK,ORREC,ORRECNT,X,Y
|
---|
27 | DEVICE ;PRINT THE REPORT IF YOU WANT
|
---|
28 | W !!,"You can print a list of corrections if you wish.",!
|
---|
29 | S DIR(0)="Y",DIR("A")="Would you like a list",DIR("B")="Y"
|
---|
30 | D ^DIR G:($D(DIRUT)!(Y=0)) QUIT K DIR,Y
|
---|
31 | I ORCNT>50 W !!,"You have ",ORCNT," corrections, you may want to send output to a printer!",!
|
---|
32 | S %ZIS="Q" D ^%ZIS G QUIT:POP
|
---|
33 | I $D(IO("Q")) D QUE G QUIT
|
---|
34 | U IO D PRT
|
---|
35 | QUIT D ^%ZISC K %ZIS,DIR,DIROUT,DIRUT,ORCNT,ORJOB,ORNUM,ORNODE,ORPAGE,POP,Y,ZTREQ,ZTQUEUED,^TMP("ORPKFIX")
|
---|
36 | Q
|
---|
37 | PRT ;SHOW THE OUTPUT
|
---|
38 | I $D(ZTQUEUED) S ZTREQ="@"
|
---|
39 | S ORPAGE=1 D PAGE
|
---|
40 | I '$D(^TMP("ORPKFIX")) W !,"No corrections made" G QUIT
|
---|
41 | S ORJOB=0 F S ORJOB=$O(^TMP("ORPKFIX",ORJOB)) G:'ORJOB QUIT D G:'$D(ORPAGE) QUIT
|
---|
42 | .S ORNUM=0 F S ORNUM=$O(^TMP("ORPKFIX",ORJOB,ORNUM)) Q:'ORNUM D I $Y>(IOSL-5) S ORPAGE=ORPAGE+1 D PAGE Q:'$D(ORPAGE)
|
---|
43 | .. S ORNODE=$G(^TMP("ORPKFIX",ORJOB,ORNUM))
|
---|
44 | .. W !,"Order ",$P(ORNODE,"^")," repointed from ",$E($P(ORNODE,"^",2),1,20)," to ",$E($P(ORNODE,"^",3),1,20)
|
---|
45 | .. Q
|
---|
46 | G QUIT
|
---|
47 | PAGE ;NEW PAGE
|
---|
48 | I $E(IOST,1,2)["C-",ORPAGE>1 W ! S DIR(0)="E" D ^DIR K:+Y'>0 ORPAGE Q:'$D(ORPAGE)
|
---|
49 | W @IOF,"Corrections from OR*2.5*37 ORPKFIX",?65,"Page: ",ORPAGE
|
---|
50 | W ! F DASH=1:1:78 W "-"
|
---|
51 | K DASH,DIR Q
|
---|
52 | QUE ;QUE THE OUTPUT
|
---|
53 | S ZTRTN="PRT^ORPKFIX",ZTDESC="OR*2.5*37 corrections"
|
---|
54 | S ZTSAVE("^TMP(""ORPKFIX"",")=""
|
---|
55 | D ^%ZTLOAD
|
---|
56 | I '$G(ZTSK) W !!,"Report cancelled!",!
|
---|
57 | E W !,"Report queued!"
|
---|
58 | D HOME^%ZIS
|
---|
59 | K ZTDESC,ZTRTN,ZTSAVE,ZTSK
|
---|