source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR110P.m@ 1094

Last change on this file since 1094 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.1 KB
Line 
1RMPR110P ;VMP/RB - LOCATE/FIX/REPORT POINTER PROBLEMS 665.72 TO 660 ;05/02/06
2 ;;3.0;Prosthetics;**110**;06/20/05;Build 10
3 ;;
4 ;1. Post install to locate/fix/report pointer error issues between
5 ; file 665.72 and 660 caused by inept fileman stuff during
6 ; O2 Post Billing.
7 S (SITE,RECTOT,ERRTOT)=0 K ^TMP($J,"RMPR110P"),^TMP("RMPRFIX",$J)
8A1 S SITE=$O(^RMPO(665.72,SITE)),MON=0 G B10:SITE=""!(SITE]"@")
9A1A S MON=$O(^RMPO(665.72,SITE,1,MON)),VEND=0 G A1:MON=""
10A2 S VEND=$O(^RMPO(665.72,SITE,1,MON,1,VEND)),DFN=0 G A1A:VEND=""
11A3 K IT S IT=0 S DFN=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN)),ITEM=0 G:DFN=""!(DFN]"@") A2
12A4 S ITEM=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM)) G:ITEM=""!(ITEM]"@") A3
13 S RR=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0),R660=$P(RR,U,16)
14 G A4:R660="" S R6=$G(^RMPR(660,R660,0)) I R6="" S ^TMP($J,"RMPR110P",6,SITE,MON,VEND,DFN,ITEM)=RR
15 I DFN'=$P(R6,U,2) D
16 . S ERRTOT=ERRTOT+1
17 . S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,ITEM,R660,0)=ITEM_U_IT_U_$P(R6,U,11)
18 . 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)
19 I IT=0,DFN=$P(R6,U,2) S IT=R660
20 G A4
21B10 ;GRAB ALL ERROR 665.72 POINTER RELATIONS AND DETERMINE CORRECT POINTER
22 S SITE=0,U="^",CHK=$P(^RMPR(660,0),U,3)
23B11 S SITE=$O(^TMP($J,"RMPR110P",1,SITE)),MON=0,VEND=0 G PRINT:SITE=""
24B11B S MON=$O(^TMP($J,"RMPR110P",1,SITE,MON)),VEND=0 G B11:MON=""
25B12 S VEND=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND)),DFN=0 G B11B:VEND=""
26B13 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)=""
27B14 S ITEM=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM)) G C15:ITEM=""!(ITEM]"@")
28 S R=^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN,1,ITEM,0),R660=$P(R,U,16)
29 G:R660="" B14
30 S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,2,ITEM,R660)=$G(^RMPR(660,R660,0)),ER(R660)=ITEM
31 G B14
32C15 S BADITEM=0,XITEM=0
33C16 S XITEM=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM)),BAD660=0 G:XITEM="" B13
34C17 S BAD660=$O(^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,1,XITEM,BAD660))
35 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)
36 S RSH=$P(B0,U,2),LK1=RSH-5000,LK2=RSH+5000 S:LK1<0 LK1=0
37 S FIND660=+$P(B0,U,3) I FIND660 D G:FIND660 C19
38 . S REC660=$G(^RMPR(660,FIND660,0))
39 . I DFN'=$P(REC660,U,2) S FIND660=0
40C18 S FIND660=0 F I=LK1:1:LK2 S REC660=$G(^RMPR(660,I,0)) D:REC660'="" Q:FIND660
41 . Q:$P(REC660,U,2)'=DFN
42 . Q:$P(REC660,U,9)'=VEND
43 . Q:$P(REC660,U,6)'=$P(B1,U)
44 . Q:$P(REC660,U,7)'=$P(B1,U,7)
45 . Q:$FN($P(REC660,U,16),"p",2)'=$FN($P(B1,U,6),"p",2)
46 . Q:$P(REC660,U,8)'=$P(B1,U,15)
47 . S FIND660=I
48 I FIND660=0,RSH=0 G C30
49C19 I FIND660 D
50 . S ^TMP($J,"RMPR110P",2,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0_"^"_FIND660_"^"_REC660
51 . 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
52 . 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
53 . S ^TMP($J,"RMPR110P",1,SITE,MON,VEND,DFN,3,XITEM,FIND660,0)=^RMPR(660,FIND660,0)
54 . ;SET CORRECT 660 POINTER INTO 665.72 HERE
55 . K DIE,DA,DR S DA(4)=SITE,DA(3)=MON,DA(2)=VEND,DA(1)=DFN
56 . S DIE="^RMPO(665.72,"_DA(4)_",1,"_DA(3)_",1,"_DA(2)_",""V"","_DA(1)
57 . S DIE=DIE_",1,",DA=XITEM,DR="15////^S X=FIND660" D ^DIE
58 I 'FIND660 S ^TMP($J,"RMPR110P",5,SITE,MON,VEND,DFN,1,XITEM,BAD660)=B0 ;CANNOT LOGICALLY LOCATE CORRECT POINTER........
59 G C16
60C30 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
61C31 S XX=$O(^RMPO(665.72,SITE,1,MON,1,VEND,"V",DFN),-1),YY=0 Q:XX=""
62C32 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
63 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)
64 S REC660=""
65 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)
66 I $P(REC660,U,2)'=DFN D G:'FIND660 C18
67 . I +$P(B0,U,3)>5000 S F660=$P(B0,U,3)\1
68 . I X660,'F660 S F660=X660
69 . S LK1=F660-5000,LK2=F660+5000,FIND660=0,RSH=1 S:LK1<0 LK1=0
70 G C19
71PRINT ;
72 D NOW^%DTC S Y=% X ^DD("DD") S RMRDATE=Y
73PRINT2 ; Update the ^TMP("RMPRFIX" MAIL REPORT
74 ;
75 S SP="",$P(SP," ",85)=" "
76 S ^TMP("RMPRFIX",$J,1)="File 665.72/660 Pointer Errors"_$E(SP,1,16)_"Run Date: "_RMRDATE_$E(SP,1,10)
77 S ^TMP("RMPRFIX",$J,2)=$E(SP,1,3)_". . . 660 pointer error internal info . . ."
78 S ^TMP("RMPRFIX",$J,3)="site month vendor DFN item 660 pntr"_$E(SP,1,8)_"660 ptr correction"
79 S ^TMP("RMPRFIX",$J,4)=""
80 S CNT110=4
81 N RMEND,PG S RTYP=2
82 S (SITE,PG)=0,U="^",IOSL=66 S:$E(IOST,1,2)="C-" IOSL=22
83P1 S SITE=$O(^TMP($J,"RMPR110P",RTYP,SITE)),MON=0 G PRINT3:SITE=""
84P1A S MON=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON)),VEND=0 G P1:MON=""
85P2 S VEND=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND)),DFN=0 G P1A:VEND=""
86P3 S DFN=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN)),ITEM=0 G:DFN="" P2
87P5 S BADITEM=0,XITEM=0
88P6 S XITEM=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM)),BAD660=0 G:XITEM="" P3
89 S BAD660=$O(^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM,BAD660))
90 S B0=^TMP($J,"RMPR110P",RTYP,SITE,MON,VEND,DFN,1,XITEM,BAD660)
91 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)
92 G P6
93PRINT3 I RTYP=2 D
94 . S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=""
95 . S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)="==>>> TOTAL POINTERS CORRECTED: "_ERRTOT
96 I RTYP=2 S RTYP=4,(SITE,PG)=0 D G P1
97 . F I=1:1:4 S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=""
98 . S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)="==>>> NEW 660 RECORD DOES NOT MATCH DFN OF 665.72, NOT CORRECTED"
99 I RTYP=4 S RTYP=5,(SITE,PG)=0 D G P1
100 . F I=1:1:4 S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)=""
101 . S CNT110=CNT110+1,^TMP("RMPRFIX",$J,CNT110)="==>>> LOGICAL POINTER COULD NOT BE FOUND FOR 665.72 ENTRY, NOT CORRECTED"
102 D MAIL
103EXIT K SITE,RECTOT,ERRTOT,MON,VEND,IT,DFN,ITEM,RR,R660,R6,DTOUT,ANS,CHK,BADITEM,XITEM,B0,B1,RSH,LK1,LK2,FIND660
104 K REC660,XX,YY,X660,RMRDATE,PG,RTYP,RMEND,DIE,DA,DR,DIR,%,BAD660,F660,R,SP,Y
105 K ^TMP($J),^TMP("RMPRTXT",$J),^TMP("RMPRFIX",$J)
106 Q
107MAIL ;Send results of cleanup in a mail message to initiator
108 N I,XMSUB,XMTEXT,XMDUZ,XMY,DIFROM,CNT110
109 S XMSUB="Patch RMPR*3.0*110 Clean up completed"
110 S XMDUZ="Patch RMPR*3.0*110 Clean up job"
111 S XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
112 S XMTEXT="^TMP(""RMPRTXT"",$J,"
113 K ^TMP("RMPRTXT",$J)
114 ; set up header and count
115 S I=1
116 S ^TMP("RMPRTXT",$J,I)="The correction of invalid pointers between files 665.72 & 660 has completed.",I=I+1
117 S ^TMP("RMPRTXT",$J,I)="Below is a listing of pointers found and the correct pointer located",I=I+1
118 S ^TMP("RMPRTXT",$J,I)="",I=I+1
119 S ^TMP("RMPRTXT",$J,I)="",I=I+1
120 I ERRTOT=0 S ^TMP("RMPRTXT",$J,I)="No pointer errors found for files 660/665.72.",I=I+1
121 S ^TMP("RMPRTXT",$J,I)="",I=I+1
122 ; set up message text
123 S CNT110=0 F S CNT110=$O(^TMP("RMPRFIX",$J,CNT110)) Q:CNT110="" D
124 .S ^TMP("RMPRTXT",$J,I)=^TMP("RMPRFIX",$J,CNT110),I=I+1
125 D ^XMD ;send results
126 Q
Note: See TracBrowser for help on using the repository browser.