| 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
|
|---|
