RMPR110P ;VMP/RB - LOCATE/FIX/REPORT POINTER PROBLEMS 665.72 TO 660 ;05/02/06
;;3.0;Prosthetics;**110**;06/20/05;Build 10
;;
;1. Post install to locate/fix/report pointer error issues between
; file 665.72 and 660 caused by inept fileman stuff during
; O2 Post Billing.
S (SITE,RECTOT,ERRTOT)=0 K ^TMP($J,"RMPR110P"),^TMP("RMPRFIX",$J)
A1 S SITE=$O(^RMPO(665.72,SITE)),MON=0 G B10:SITE=""!(SITE]"@")
A1A S MON=$O(^RMPO(665.72,SITE,1,MON)),VEND=0 G A1:MON=""
A2 S VEND=$O(^RMPO(665.72,SITE,1,MON,1,VEND)),DFN=0 G A1A:VEND=""
A3 K IT S IT=0 S DFN=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN)),ITEM=0 G:DFN=""!(DFN]"@") A2
A4 S ITEM=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM)) G:ITEM=""!(ITEM]"@") A3
S RR=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0),R660=$P(RR,U,16)
G A4:R660="" S R6=$G(^RMPR(660,R660,0)) I R6="" S ^TMP($J,"RMPR110P",6,SITE,MON,VEND,DFN,ITEM)=RR
I DFN'=$P(R6,U,2) D
. S ERRTOT=ERRTOT+1
. S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,ITEM,R660,0)=ITEM_U_IT_U_$P(R6,U,11)
. S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,ITEM,R660,1)=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0)
I IT=0,DFN=$P(R6,U,2) S IT=R660
G A4
B10 ;GRAB ALL ERROR 665.72 POINTER RELATIONS AND DETERMINE CORRECT POINTER
S SITE=0,U="^",CHK=$P(^RMPR(660,0),U,3)
B11 S SITE=$O(^TMP($J,"RMPR110P",1,SITE)),MON=0,VEND=0 G PRINT:SITE=""
B11B S MON=$O(^TMP($J,"RMPR110P",1,SITE,MON)),VEND=0 G B11:MON=""
B12 S VEND=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND)),DFN=0 G B11B:VEND=""
B13 S DFN=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN)),ITEM=0 K ER S RSH="" G B12:DFN="" S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,3)=""
B14 S ITEM=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM)) G C15:ITEM=""!(ITEM]"@")
S R=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0),R660=$P(R,U,16)
G:R660="" B14
S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,2,ITEM,R660)=$G(^RMPR(660,R660,0)),ER(R660)=ITEM
G B14
C15 S BADITEM=0,XITEM=0
C16 S XITEM=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM)),BAD660=0 G:XITEM="" B13
C17 S BAD660=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660))
S B0=^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660,0),B1=^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660,1)
S RSH=$P(B0,U,2),LK1=RSH-5000,LK2=RSH+5000 S:LK1<0 LK1=0
S FIND660=+$P(B0,U,3) I FIND660 D G:FIND660 C19
. S REC660=$G(^RMPR(660,FIND660,0))
. I DFN'=$P(REC660,U,2) S FIND660=0
C18 S FIND660=0 F I=LK1:1:LK2 S REC660=$G(^RMPR(660,I,0)) D:REC660'="" Q:FIND660
. Q:$P(REC660,U,2)'=DFN
. Q:$P(REC660,U,9)'=VEND
. Q:$P(REC660,U,6)'=$P(B1,U)
. Q:$P(REC660,U,7)'=$P(B1,U,7)
. Q:$FN($P(REC660,U,16),"p",2)'=$FN($P(B1,U,6),"p",2)
. Q:$P(REC660,U,8)'=$P(B1,U,15)
. S FIND660=I
I FIND660=0,RSH=0 G C30
C19 I FIND660 D
. S ^TMP($J,"RMPR110P",2,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660_"^"_REC660
. I DFN'=$P(REC660,U,2) S ^TMP($J,"RMPR110P",4,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660_"^"_REC660 Q ;FIND 660 DOES NOT MATCH DFN VALUE FOUND
. I FIND660'=$P(B0,U,3) S ^TMP($J,"RMPR110P",3,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660 ;FIND 660 DOES NOT MATCH RECORDED VALUE FOUND
. S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,3,XITEM,FIND660,0)=^RMPR(660,FIND660,0)
. ;SET CORRECT 660 POINTER INTO 665.72 HERE
. K DIE,DA,DR S DA(4)=SITE,DA(3)=MON,DA(2)=VEND,DA(1)=DFN
. S DIE="^RMPO(665.72,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","_DA(1)
. S DIE=DIE_",1,",DA=XITEM,DR="15////^S X=FIND660" D ^DIE
I 'FIND660 S ^TMP($J,"RMPR110P",5,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0 ;CANNOT LOGICALLY LOCATE CORRECT POINTER........
G C16
C30 S FIND660=+$P(B0,U,3),REC660="",F660=0 S:FIND660 REC660=$G(^RMPR(660,FIND660,0)) G:FIND660?.N&(DFN=$P(REC660,U,2)) C19 S XX=DFN,YY=0,X660="",FIND660=0
C31 S XX=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN),-1),YY=0 Q:XX=""
C32 I $D(^TMP($J,"RMPR110P",1,SITE,MON,VEND,XX)) S XX=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",XX),-1) Q:XX="" G C32
F S YY=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",XX,1,YY)) Q:YY=""!(YY]"@") S X660=$P(^RMPO(665.72,SITE,1,MON,1,VEND,"V",XX,1,YY,0),U,16)
S REC660=""
I X660 F I=1:1:5 I $D(^RMPR(660,X660+I)) S FIND660=X660+I,REC660=^RMPR(660,FIND660,0) Q:DFN=$P(REC660,U,2)
I $P(REC660,U,2)'=DFN D G:'FIND660 C18
. I +$P(B0,U,3)>5000 S F660=$P(B0,U,3)\1
. I X660,'F660 S F660=X660
. S LK1=F660-5000,LK2=F660+5000,FIND660=0,RSH=1 S:LK1<0 LK1=0
G C19
PRINT ;
D NOW^%DTC S Y=% X ^DD("DD") S RMRDATE=Y
PRINT2 ; Update the ^TMP("RMPRFIX" MAIL REPORT
;
S SP="",$P(SP," ",85)=" "
S ^TMP("RMPRFIX",$J,1)="File 665.72/660 Pointer Errors"_$E(SP,1,16)_"Run Date: "_RMRDATE_$E(SP,1,10)
S ^TMP("RMPRFIX",$J,2)=$E(SP,1,3)_". . . 660 pointer error internal info . . ."
S ^TMP("RMPRFIX",$J,3)="site month vendor DFN item 660 pntr"_$E(SP,1,8)_"660 ptr correction"
S ^TMP("RMPRFIX",$J,4)=""
S CNT110=4
N RMEND,PG S RTYP=2
S (SITE,PG)=0,U="^",IOSL=66 S:$E(IOST,1,2)="C-" IOSL=22
P1 S SITE=$O(^TMP($J,"RMPR110P",RTYP,SITE)),MON=0 G PRINT3:SITE=""
P1A S MON=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON)),VEND=0 G P1:MON=""
P2 S VEND=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND)),DFN=0 G P1A:VEND=""
P3 S DFN=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN)),ITEM=0 G:DFN="" P2
P5 S BADITEM=0,XITEM=0
P6 S XITEM=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM)),BAD660=0 G:XITEM="" P3
S BAD660=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM,BAD660))
S B0=^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM,BAD660)
S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=$J(SITE,3)_$J(MON,11)_$J(VEND,9)_$J(DFN,11)_$J(XITEM,7)_$J(BAD660,10)_$J($P(B0,U,4),18)
G P6
PRINT3 I RTYP=2 D
. S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=""
. S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)="==>>> TOTAL POINTERS CORRECTED: "_ERRTOT
I RTYP=2 S RTYP=4,(SITE,PG)=0 D G P1
. F I=1:1:4 S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=""
. S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)="==>>> NEW 660 RECORD DOES NOT MATCH DFN OF 665.72, NOT CORRECTED"
I RTYP=4 S RTYP=5,(SITE,PG)=0 D G P1
. F I=1:1:4 S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=""
. S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)="==>>> LOGICAL POINTER COULD NOT BE FOUND FOR 665.72 ENTRY, NOT CORRECTED"
D MAIL
EXIT K SITE,RECTOT,ERRTOT,MON,VEND,IT,DFN,ITEM,RR,R660,R6,DTOUT,ANS,CHK,BADITEM,XITEM,B0,B1,RSH,LK1,LK2,FIND660
K REC660,XX,YY,X660,RMRDATE,PG,RTYP,RMEND,DIE,DA,DR,DIR,%,BAD660,F660,R,SP,Y
K ^TMP($J),^TMP("RMPRTXT",$J),^TMP("RMPRFIX",$J)
Q
MAIL ;Send results of cleanup in a mail message to initiator
N I,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT110
S XMSUB="Patch RMPR*3.0*110 Clean up completed"
S XMDUZ="Patch RMPR*3.0*110 Clean up job"
S XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
S XMTEXT="^TMP(""RMPRTXT"",$J,"
K ^TMP("RMPRTXT",$J)
; set up header and count
S I=1
S ^TMP("RMPRTXT",$J,I)="The correction of invalid pointers between files 665.72 & 660 has completed.",I=I+1
S ^TMP("RMPRTXT",$J,I)="Below is a listing of pointers found and the correct pointer located",I=I+1
S ^TMP("RMPRTXT",$J,I)="",I=I+1
S ^TMP("RMPRTXT",$J,I)="",I=I+1
I ERRTOT=0 S ^TMP("RMPRTXT",$J,I)="No pointer errors found for files 660/665.72.",I=I+1
S ^TMP("RMPRTXT",$J,I)="",I=I+1
; set up message text
S CNT110=0 F S CNT110=$O(^TMP("RMPRFIX",$J,CNT110)) Q:CNT110="" D
.S ^TMP("RMPRTXT",$J,I)=^TMP("RMPRFIX",$J,CNT110),I=I+1
D ^XMD ;send results
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR110P 7394 printed Nov 22, 2024@17:41:37 Page 2
RMPR110P ;VMP/RB - LOCATE/FIX/REPORT POINTER PROBLEMS 665.72 TO 660 ;05/02/06
+1 ;;3.0;Prosthetics;**110**;06/20/05;Build 10
+2 ;;
+3 ;1. Post install to locate/fix/report pointer error issues between
+4 ; file 665.72 and 660 caused by inept fileman stuff during
+5 ; O2 Post Billing.
+6 SET (SITE,RECTOT,ERRTOT)=0
KILL ^TMP($JOB,"RMPR110P"),^TMP("RMPRFIX",$JOB)
A1 SET SITE=$ORDER(^RMPO(665.72,SITE))
SET MON=0
if SITE=""!(SITE]"@")
GOTO B10
A1A SET MON=$ORDER(^RMPO(665.72,SITE,1,MON))
SET VEND=0
if MON=""
GOTO A1
A2 SET VEND=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND))
SET DFN=0
if VEND=""
GOTO A1A
A3 KILL IT
SET IT=0
SET DFN=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN))
SET ITEM=0
if DFN=""!(DFN]"@")
GOTO A2
A4 SET ITEM=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM))
if ITEM=""!(ITEM]"@")
GOTO A3
+1 SET RR=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0)
SET R660=$PIECE(RR,U,16)
+2 if R660=""
GOTO A4
SET R6=$GET(^RMPR(660,R660,0))
IF R6=""
SET ^TMP($JOB,"RMPR110P",6,SITE,MON,VEND,DFN,ITEM)=RR
+3 IF DFN'=$PIECE(R6,U,2)
Begin DoDot:1
+4 SET ERRTOT=ERRTOT+1
+5 SET ^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,1,ITEM,R660,0)=ITEM_U_IT_U_$PIECE(R6,U,11)
+6 SET ^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,1,ITEM,R660,1)=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0)
End DoDot:1
+7 IF IT=0
IF DFN=$PIECE(R6,U,2)
SET IT=R660
+8 GOTO A4
B10 ;GRAB ALL ERROR 665.72 POINTER RELATIONS AND DETERMINE CORRECT POINTER
+1 SET SITE=0
SET U="^"
SET CHK=$PIECE(^RMPR(660,0),U,3)
B11 SET SITE=$ORDER(^TMP($JOB,"RMPR110P",1,SITE))
SET MON=0
SET VEND=0
if SITE=""
GOTO PRINT
B11B SET MON=$ORDER(^TMP($JOB,"RMPR110P",1,SITE,MON))
SET VEND=0
if MON=""
GOTO B11
B12 SET VEND=$ORDER(^TMP($JOB,"RMPR110P",1,SITE,MON,VEND))
SET DFN=0
if VEND=""
GOTO B11B
B13 SET DFN=$ORDER(^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN))
SET ITEM=0
KILL ER
SET RSH=""
if DFN=""
GOTO B12
SET ^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,3)=""
B14 SET ITEM=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM))
if ITEM=""!(ITEM]"@")
GOTO C15
+1 SET R=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0)
SET R660=$PIECE(R,U,16)
+2 if R660=""
GOTO B14
+3 SET ^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,2,ITEM,R660)=$GET(^RMPR(660,R660,0))
SET ER(R660)=ITEM
+4 GOTO B14
C15 SET BADITEM=0
SET XITEM=0
C16 SET XITEM=$ORDER(^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM))
SET BAD660=0
if XITEM=""
GOTO B13
C17 SET BAD660=$ORDER(^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660))
+1 SET B0=^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660,0)
SET B1=^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660,1)
+2 SET RSH=$PIECE(B0,U,2)
SET LK1=RSH-5000
SET LK2=RSH+5000
if LK1<0
SET LK1=0
+3 SET FIND660=+$PIECE(B0,U,3)
IF FIND660
Begin DoDot:1
+4 SET REC660=$GET(^RMPR(660,FIND660,0))
+5 IF DFN'=$PIECE(REC660,U,2)
SET FIND660=0
End DoDot:1
if FIND660
GOTO C19
C18 SET FIND660=0
FOR I=LK1:1:LK2
SET REC660=$GET(^RMPR(660,I,0))
if REC660'=""
Begin DoDot:1
+1 if $PIECE(REC660,U,2)'=DFN
QUIT
+2 if $PIECE(REC660,U,9)'=VEND
QUIT
+3 if $PIECE(REC660,U,6)'=$PIECE(B1,U)
QUIT
+4 if $PIECE(REC660,U,7)'=$PIECE(B1,U,7)
QUIT
+5 if $FNUMBER($PIECE(REC660,U,16),"p",2)'=$FNUMBER($PIECE(B1,U,6),"p",2)
QUIT
+6 if $PIECE(REC660,U,8)'=$PIECE(B1,U,15)
QUIT
+7 SET FIND660=I
End DoDot:1
if FIND660
QUIT
+8 IF FIND660=0
IF RSH=0
GOTO C30
C19 IF FIND660
Begin DoDot:1
+1 SET ^TMP($JOB,"RMPR110P",2,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660_"^"_REC660
+2 ;FIND 660 DOES NOT MATCH DFN VALUE FOUND
IF DFN'=$PIECE(REC660,U,2)
SET ^TMP($JOB,"RMPR110P",4,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660_"^"_REC660
QUIT
+3 ;FIND 660 DOES NOT MATCH RECORDED VALUE FOUND
IF FIND660'=$PIECE(B0,U,3)
SET ^TMP($JOB,"RMPR110P",3,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660
+4 SET ^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,DFN,3,XITEM,FIND660,0)=^RMPR(660,FIND660,0)
+5 ;SET CORRECT 660 POINTER INTO 665.72 HERE
+6 KILL DIE,DA,DR
SET DA(4)=SITE
SET DA(3)=MON
SET DA(2)=VEND
SET DA(1)=DFN
+7 SET DIE="^RMPO(665.72,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","_DA(1)
+8 SET DIE=DIE_",1,"
SET DA=XITEM
SET DR="15////^S X=FIND660"
DO ^DIE
End DoDot:1
+9 ;CANNOT LOGICALLY LOCATE CORRECT POINTER........
IF 'FIND660
SET ^TMP($JOB,"RMPR110P",5,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0
+10 GOTO C16
C30 SET FIND660=+$PIECE(B0,U,3)
SET REC660=""
SET F660=0
if FIND660
SET REC660=$GET(^RMPR(660,FIND660,0))
if FIND660?.N&(DFN=$PIECE(REC660,U,2))
GOTO C19
SET XX=DFN
SET YY=0
SET X660=""
SET FIND660=0
C31 SET XX=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN),-1)
SET YY=0
if XX=""
QUIT
C32 IF $DATA(^TMP($JOB,"RMPR110P",1,SITE,MON,VEND,XX))
SET XX=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND,"V",XX),-1)
if XX=""
QUIT
GOTO C32
+1 FOR
SET YY=$ORDER(^RMPO(665.72,SITE,1,MON,1,VEND,"V",XX,1,YY))
if YY=""!(YY]"@")
QUIT
SET X660=$PIECE(^RMPO(665.72,SITE,1,MON,1,VEND,"V",XX,1,YY,0),U,16)
+2 SET REC660=""
+3 IF X660
FOR I=1:1:5
IF $DATA(^RMPR(660,X660+I))
SET FIND660=X660+I
SET REC660=^RMPR(660,FIND660,0)
if DFN=$PIECE(REC660,U,2)
QUIT
+4 IF $PIECE(REC660,U,2)'=DFN
Begin DoDot:1
+5 IF +$PIECE(B0,U,3)>5000
SET F660=$PIECE(B0,U,3)\1
+6 IF X660
IF 'F660
SET F660=X660
+7 SET LK1=F660-5000
SET LK2=F660+5000
SET FIND660=0
SET RSH=1
if LK1<0
SET LK1=0
End DoDot:1
if 'FIND660
GOTO C18
+8 GOTO C19
PRINT ;
+1 DO NOW^%DTC
SET Y=%
XECUTE ^DD("DD")
SET RMRDATE=Y
PRINT2 ; Update the ^TMP("RMPRFIX" MAIL REPORT
+1 ;
+2 SET SP=""
SET $PIECE(SP," ",85)=" "
+3 SET ^TMP("RMPRFIX",$JOB,1)="File 665.72/660 Pointer Errors"_$EXTRACT(SP,1,16)_"Run Date: "_RMRDATE_$EXTRACT(SP,1,10)
+4 SET ^TMP("RMPRFIX",$JOB,2)=$EXTRACT(SP,1,3)_". . . 660 pointer error internal info . . ."
+5 SET ^TMP("RMPRFIX",$JOB,3)="site month vendor DFN item 660 pntr"_$EXTRACT(SP,1,8)_"660 ptr correction"
+6 SET ^TMP("RMPRFIX",$JOB,4)=""
+7 SET CNT110=4
+8 NEW RMEND,PG
SET RTYP=2
+9 SET (SITE,PG)=0
SET U="^"
SET IOSL=66
if $EXTRACT(IOST,1,2)="C-"
SET IOSL=22
P1 SET SITE=$ORDER(^TMP($JOB,"RMPR110P",RTYP,SITE))
SET MON=0
if SITE=""
GOTO PRINT3
P1A SET MON=$ORDER(^TMP($JOB,"RMPR110P",RTYP,SITE,MON))
SET VEND=0
if MON=""
GOTO P1
P2 SET VEND=$ORDER(^TMP($JOB,"RMPR110P",RTYP,SITE,MON,VEND))
SET DFN=0
if VEND=""
GOTO P1A
P3 SET DFN=$ORDER(^TMP($JOB,"RMPR110P",RTYP,SITE,MON,VEND,DFN))
SET ITEM=0
if DFN=""
GOTO P2
P5 SET BADITEM=0
SET XITEM=0
P6 SET XITEM=$ORDER(^TMP($JOB,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM))
SET BAD660=0
if XITEM=""
GOTO P3
+1 SET BAD660=$ORDER(^TMP($JOB,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM,BAD660))
+2 SET B0=^TMP($JOB,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM,BAD660)
+3 SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)=$JUSTIFY(SITE,3)_$JUSTIFY(MON,11)_$JUSTIFY(VEND,9)_$JUSTIFY(DFN,11)_$JUSTIFY(XITEM,7)_$JUSTIFY(BAD660,10)_$JUSTIFY($PIECE(B0,U,4),18)
+4 GOTO P6
PRINT3 IF RTYP=2
Begin DoDot:1
+1 SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)=""
+2 SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)="==>>> TOTAL POINTERS CORRECTED: "_ERRTOT
End DoDot:1
+3 IF RTYP=2
SET RTYP=4
SET (SITE,PG)=0
Begin DoDot:1
+4 FOR I=1:1:4
SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)=""
+5 SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)="==>>> NEW 660 RECORD DOES NOT MATCH DFN OF 665.72, NOT CORRECTED"
End DoDot:1
GOTO P1
+6 IF RTYP=4
SET RTYP=5
SET (SITE,PG)=0
Begin DoDot:1
+7 FOR I=1:1:4
SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)=""
+8 SET CNT110=CNT110+1
SET ^TMP("RMPRFIX",$JOB,CNT110)="==>>> LOGICAL POINTER COULD NOT BE FOUND FOR 665.72 ENTRY, NOT CORRECTED"
End DoDot:1
GOTO P1
+9 DO MAIL
EXIT KILL SITE,RECTOT,ERRTOT,MON,VEND,IT,DFN,ITEM,RR,R660,R6,DTOUT,ANS,CHK,BADITEM,XITEM,B0,B1,RSH,LK1,LK2,FIND660
+1 KILL REC660,XX,YY,X660,RMRDATE,PG,RTYP,RMEND,DIE,DA,DR,DIR,%,BAD660,F660,R,SP,Y
+2 KILL ^TMP($JOB),^TMP("RMPRTXT",$JOB),^TMP("RMPRFIX",$JOB)
+3 QUIT
MAIL ;Send results of cleanup in a mail message to initiator
+1 NEW I,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT110
+2 SET XMSUB="Patch RMPR*3.0*110 Clean up completed"
+3 SET XMDUZ="Patch RMPR*3.0*110 Clean up job"
+4 SET XMY(.5)=""
if $GET(DUZ)
SET XMY(DUZ)=""
+5 SET XMTEXT="^TMP(""RMPRTXT"",$J,"
+6 KILL ^TMP("RMPRTXT",$JOB)
+7 ; set up header and count
+8 SET I=1
+9 SET ^TMP("RMPRTXT",$JOB,I)="The correction of invalid pointers between files 665.72 & 660 has completed."
SET I=I+1
+10 SET ^TMP("RMPRTXT",$JOB,I)="Below is a listing of pointers found and the correct pointer located"
SET I=I+1
+11 SET ^TMP("RMPRTXT",$JOB,I)=""
SET I=I+1
+12 SET ^TMP("RMPRTXT",$JOB,I)=""
SET I=I+1
+13 IF ERRTOT=0
SET ^TMP("RMPRTXT",$JOB,I)="No pointer errors found for files 660/665.72."
SET I=I+1
+14 SET ^TMP("RMPRTXT",$JOB,I)=""
SET I=I+1
+15 ; set up message text
+16 SET CNT110=0
FOR
SET CNT110=$ORDER(^TMP("RMPRFIX",$JOB,CNT110))
if CNT110=""
QUIT
Begin DoDot:1
+17 SET ^TMP("RMPRTXT",$JOB,I)=^TMP("RMPRFIX",$JOB,CNT110)
SET I=I+1
End DoDot:1
+18 ;send results
DO ^XMD
+19 QUIT
