- 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 Mar 13, 2025@21:37:30 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
