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