ORPKFIX ;HISC/JFR - FIX BAD PACKAGE POINTERS IN ^OR(100 11/7/95 10:00
;;2.5;ORDER ENTRY/RESULTS REPORTING;**37,44**;Jan 08, 1993
; This routine will repoint any orders in file 100 that have a
; different package associated with the order than the protocol
; that created the order.
EN D DT^DICRW
I $D(^TMP("ORPKFIX")) D
.W !!,"It appears you may have errored out running this patch before."
.W !,"Your count of records corrected will be off but all corrections "
.W !,"will be shown if you print the report."
.W !! H 2
W !,"I'll check your ORDER file for bad PACKAGE file pointers.",!
S (ORCNT,ORREC,ORRECNT)=0 F S ORREC=$O(^OR(100,ORREC)) Q:'ORREC D
.S ORRECNT=ORRECNT+1 W:'(ORRECNT#1000) "."
.S ORPROT=$P($G(^OR(100,ORREC,0)),"^",5) Q:ORPROT'["ORD"
.S ORPROTPK=$P($G(^ORD(101,+ORPROT,0)),"^",12),ORDPK=$P($G(^OR(100,ORREC,0)),"^",14)
.Q:$G(^OR(100,ORREC,1,1,0))["DC"
.I ORPROTPK'=ORDPK D Q
..S ORCNT=ORCNT+1
..S $P(^OR(100,ORREC,0),"^",14)=ORPROTPK
..S X=ORDPK S DIC="^DIC(9.4,",DIC(0)="XN" D ^DIC S ORDPK=$P(Y,"^",2)
..S X=ORPROTPK S DIC="^DIC(9.4,",DIC(0)="XN" D ^DIC S ORPROTPK=$P(Y,"^",2)
..S ^TMP("ORPKFIX",$J,ORREC)=ORREC_"^"_ORDPK_"^"_ORPROTPK
W !!,"Finished"
W !!,ORCNT," Orders have been fixed."
K DIC,ORDPK,ORPROT,ORPROTPK,ORREC,ORRECNT,X,Y
DEVICE ;PRINT THE REPORT IF YOU WANT
W !!,"You can print a list of corrections if you wish.",!
S DIR(0)="Y",DIR("A")="Would you like a list",DIR("B")="Y"
D ^DIR G:($D(DIRUT)!(Y=0)) QUIT K DIR,Y
I ORCNT>50 W !!,"You have ",ORCNT," corrections, you may want to send output to a printer!",!
S %ZIS="Q" D ^%ZIS G QUIT:POP
I $D(IO("Q")) D QUE G QUIT
U IO D PRT
QUIT D ^%ZISC K %ZIS,DIR,DIROUT,DIRUT,ORCNT,ORJOB,ORNUM,ORNODE,ORPAGE,POP,Y,ZTREQ,ZTQUEUED,^TMP("ORPKFIX")
Q
PRT ;SHOW THE OUTPUT
I $D(ZTQUEUED) S ZTREQ="@"
S ORPAGE=1 D PAGE
I '$D(^TMP("ORPKFIX")) W !,"No corrections made" G QUIT
S ORJOB=0 F S ORJOB=$O(^TMP("ORPKFIX",ORJOB)) G:'ORJOB QUIT D G:'$D(ORPAGE) QUIT
.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)
.. S ORNODE=$G(^TMP("ORPKFIX",ORJOB,ORNUM))
.. W !,"Order ",$P(ORNODE,"^")," repointed from ",$E($P(ORNODE,"^",2),1,20)," to ",$E($P(ORNODE,"^",3),1,20)
.. Q
G QUIT
PAGE ;NEW PAGE
I $E(IOST,1,2)["C-",ORPAGE>1 W ! S DIR(0)="E" D ^DIR K:+Y'>0 ORPAGE Q:'$D(ORPAGE)
W @IOF,"Corrections from OR*2.5*37 ORPKFIX",?65,"Page: ",ORPAGE
W ! F DASH=1:1:78 W "-"
K DASH,DIR Q
QUE ;QUE THE OUTPUT
S ZTRTN="PRT^ORPKFIX",ZTDESC="OR*2.5*37 corrections"
S ZTSAVE("^TMP(""ORPKFIX"",")=""
D ^%ZTLOAD
I '$G(ZTSK) W !!,"Report cancelled!",!
E W !,"Report queued!"
D HOME^%ZIS
K ZTDESC,ZTRTN,ZTSAVE,ZTSK
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPKFIX 2744 printed Sep 23, 2025@20:08:51 Page 2
ORPKFIX ;HISC/JFR - FIX BAD PACKAGE POINTERS IN ^OR(100 11/7/95 10:00
+1 ;;2.5;ORDER ENTRY/RESULTS REPORTING;**37,44**;Jan 08, 1993
+2 ; This routine will repoint any orders in file 100 that have a
+3 ; different package associated with the order than the protocol
+4 ; that created the order.
EN DO DT^DICRW
+1 IF $DATA(^TMP("ORPKFIX"))
Begin DoDot:1
+2 WRITE !!,"It appears you may have errored out running this patch before."
+3 WRITE !,"Your count of records corrected will be off but all corrections "
+4 WRITE !,"will be shown if you print the report."
+5 WRITE !!
HANG 2
End DoDot:1
+6 WRITE !,"I'll check your ORDER file for bad PACKAGE file pointers.",!
+7 SET (ORCNT,ORREC,ORRECNT)=0
FOR
SET ORREC=$ORDER(^OR(100,ORREC))
if 'ORREC
QUIT
Begin DoDot:1
+8 SET ORRECNT=ORRECNT+1
if '(ORRECNT#1000)
WRITE "."
+9 SET ORPROT=$PIECE($GET(^OR(100,ORREC,0)),"^",5)
if ORPROT'["ORD"
QUIT
+10 SET ORPROTPK=$PIECE($GET(^ORD(101,+ORPROT,0)),"^",12)
SET ORDPK=$PIECE($GET(^OR(100,ORREC,0)),"^",14)
+11 if $GET(^OR(100,ORREC,1,1,0))["DC"
QUIT
+12 IF ORPROTPK'=ORDPK
Begin DoDot:2
+13 SET ORCNT=ORCNT+1
+14 SET $PIECE(^OR(100,ORREC,0),"^",14)=ORPROTPK
+15 SET X=ORDPK
SET DIC="^DIC(9.4,"
SET DIC(0)="XN"
DO ^DIC
SET ORDPK=$PIECE(Y,"^",2)
+16 SET X=ORPROTPK
SET DIC="^DIC(9.4,"
SET DIC(0)="XN"
DO ^DIC
SET ORPROTPK=$PIECE(Y,"^",2)
+17 SET ^TMP("ORPKFIX",$JOB,ORREC)=ORREC_"^"_ORDPK_"^"_ORPROTPK
End DoDot:2
QUIT
End DoDot:1
+18 WRITE !!,"Finished"
+19 WRITE !!,ORCNT," Orders have been fixed."
+20 KILL DIC,ORDPK,ORPROT,ORPROTPK,ORREC,ORRECNT,X,Y
DEVICE ;PRINT THE REPORT IF YOU WANT
+1 WRITE !!,"You can print a list of corrections if you wish.",!
+2 SET DIR(0)="Y"
SET DIR("A")="Would you like a list"
SET DIR("B")="Y"
+3 DO ^DIR
if ($DATA(DIRUT)!(Y=0))
GOTO QUIT
KILL DIR,Y
+4 IF ORCNT>50
WRITE !!,"You have ",ORCNT," corrections, you may want to send output to a printer!",!
+5 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO QUIT
+6 IF $DATA(IO("Q"))
DO QUE
GOTO QUIT
+7 USE IO
DO PRT
QUIT DO ^%ZISC
KILL %ZIS,DIR,DIROUT,DIRUT,ORCNT,ORJOB,ORNUM,ORNODE,ORPAGE,POP,Y,ZTREQ,ZTQUEUED,^TMP("ORPKFIX")
+1 QUIT
PRT ;SHOW THE OUTPUT
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 SET ORPAGE=1
DO PAGE
+3 IF '$DATA(^TMP("ORPKFIX"))
WRITE !,"No corrections made"
GOTO QUIT
+4 SET ORJOB=0
FOR
SET ORJOB=$ORDER(^TMP("ORPKFIX",ORJOB))
if 'ORJOB
GOTO QUIT
Begin DoDot:1
+5 SET ORNUM=0
FOR
SET ORNUM=$ORDER(^TMP("ORPKFIX",ORJOB,ORNUM))
if 'ORNUM
QUIT
Begin DoDot:2
+6 SET ORNODE=$GET(^TMP("ORPKFIX",ORJOB,ORNUM))
+7 WRITE !,"Order ",$PIECE(ORNODE,"^")," repointed from ",$EXTRACT($PIECE(ORNODE,"^",2),1,20)," to ",$EXTRACT($PIECE(ORNODE,"^",3),1,20)
+8 QUIT
End DoDot:2
IF $Y>(IOSL-5)
SET ORPAGE=ORPAGE+1
DO PAGE
if '$DATA(ORPAGE)
QUIT
End DoDot:1
if '$DATA(ORPAGE)
GOTO QUIT
+9 GOTO QUIT
PAGE ;NEW PAGE
+1 IF $EXTRACT(IOST,1,2)["C-"
IF ORPAGE>1
WRITE !
SET DIR(0)="E"
DO ^DIR
if +Y'>0
KILL ORPAGE
if '$DATA(ORPAGE)
QUIT
+2 WRITE @IOF,"Corrections from OR*2.5*37 ORPKFIX",?65,"Page: ",ORPAGE
+3 WRITE !
FOR DASH=1:1:78
WRITE "-"
+4 KILL DASH,DIR
QUIT
QUE ;QUE THE OUTPUT
+1 SET ZTRTN="PRT^ORPKFIX"
SET ZTDESC="OR*2.5*37 corrections"
+2 SET ZTSAVE("^TMP(""ORPKFIX"",")=""
+3 DO ^%ZTLOAD
+4 IF '$GET(ZTSK)
WRITE !!,"Report cancelled!",!
+5 IF '$TEST
WRITE !,"Report queued!"
+6 DO HOME^%ZIS
+7 KILL ZTDESC,ZTRTN,ZTSAVE,ZTSK
