RMPR144P ;VMP/RB - FIX LAB REQUEST POINTER PROBLEM FOR FILE #660 ;12/20/07
;;3.0;Prosthetics;**144**;12/20/07;Build 17
;;
Q
FIX660 ;1. Post install to correct lab request pointer problems for Purchase
; Card order 660 entries with incorrect Lab Request "LB" pointers.
;
BUILD K ^XTMP("RMPR144P") D NOW^%DTC S RMSTART=%
S ^XTMP("RMPR144P","START COMPILE")=RMSTART
S ^XTMP("RMPR144P","END COMPILE")="RUNNING"
S ^XTMP("RMPR144P",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
0 ;FIND REPETITIVE LAB REQUEST BOGUS LINKS
S IEN=0,U="^"
1 S IEN=$O(^RMPR(660,IEN)) G EXIT:IEN=""!(IEN]"@")
S R=$G(^RMPR(660,IEN,0)),R10=$G(^RMPR(660,IEN,10))
I R=""!($P(R,U)<3050101) G 1
S LB=$G(^RMPR(660,IEN,"LB")) G 1:LB=""
S LRQ=$P(LB,U,10) G 1:LRQ=""
2 ;check invalid links
K XX,IENA,IENB
S XX=$O(^RMPR(668,"F",IEN,0))
S IENA=$P(R,U,2),RQ=$G(^RMPR(664.1,LRQ,0)),IENB=$P(RQ,U,2)
I IENA=IENB G 1
S ^XTMP("RMPR144P",660,IEN,0)=$G(LRQ)_U_$G(XX)_U_IENA_U_IENB
S ^XTMP("RMPR144P",660,IEN,1)=LB,^XTMP("RMPR144P",660,IEN,3)=$P(R,U,1,9),^XTMP("RMPR144P",660,IEN,4)=$P(RQ,U,1,9)
;W !!,IEN,?12,IENA,?22,IENB,?40,LRQ,?60,XX,!,$P(R,U,1,9),!,LB,!,$P(RQ,U,1,9)
K ^RMPR(660,IEN,"LB")
G 1
EXIT ;
D NOW^%DTC S RMEND=%
S ^XTMP("RMPR144P","END COMPILE")=RMEND
K RMEND,RMSTART,%,IEN,R,R10,LRQ,LB,XX,IENA,IENB
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR144P 1324 printed Dec 13, 2024@02:31:47 Page 2
RMPR144P ;VMP/RB - FIX LAB REQUEST POINTER PROBLEM FOR FILE #660 ;12/20/07
+1 ;;3.0;Prosthetics;**144**;12/20/07;Build 17
+2 ;;
+3 QUIT
FIX660 ;1. Post install to correct lab request pointer problems for Purchase
+1 ; Card order 660 entries with incorrect Lab Request "LB" pointers.
+2 ;
BUILD KILL ^XTMP("RMPR144P")
DO NOW^%DTC
SET RMSTART=%
+1 SET ^XTMP("RMPR144P","START COMPILE")=RMSTART
+2 SET ^XTMP("RMPR144P","END COMPILE")="RUNNING"
+3 SET ^XTMP("RMPR144P",0)=$$FMADD^XLFDT(RMSTART,90)_"^"_RMSTART
0 ;FIND REPETITIVE LAB REQUEST BOGUS LINKS
+1 SET IEN=0
SET U="^"
1 SET IEN=$ORDER(^RMPR(660,IEN))
if IEN=""!(IEN]"@")
GOTO EXIT
+1 SET R=$GET(^RMPR(660,IEN,0))
SET R10=$GET(^RMPR(660,IEN,10))
+2 IF R=""!($PIECE(R,U)<3050101)
GOTO 1
+3 SET LB=$GET(^RMPR(660,IEN,"LB"))
if LB=""
GOTO 1
+4 SET LRQ=$PIECE(LB,U,10)
if LRQ=""
GOTO 1
2 ;check invalid links
+1 KILL XX,IENA,IENB
+2 SET XX=$ORDER(^RMPR(668,"F",IEN,0))
+3 SET IENA=$PIECE(R,U,2)
SET RQ=$GET(^RMPR(664.1,LRQ,0))
SET IENB=$PIECE(RQ,U,2)
+4 IF IENA=IENB
GOTO 1
+5 SET ^XTMP("RMPR144P",660,IEN,0)=$GET(LRQ)_U_$GET(XX)_U_IENA_U_IENB
+6 SET ^XTMP("RMPR144P",660,IEN,1)=LB
SET ^XTMP("RMPR144P",660,IEN,3)=$PIECE(R,U,1,9)
SET ^XTMP("RMPR144P",660,IEN,4)=$PIECE(RQ,U,1,9)
+7 ;W !!,IEN,?12,IENA,?22,IENB,?40,LRQ,?60,XX,!,$P(R,U,1,9),!,LB,!,$P(RQ,U,1,9)
+8 KILL ^RMPR(660,IEN,"LB")
+9 GOTO 1
EXIT ;
+1 DO NOW^%DTC
SET RMEND=%
+2 SET ^XTMP("RMPR144P","END COMPILE")=RMEND
+3 KILL RMEND,RMSTART,%,IEN,R,R10,LRQ,LB,XX,IENA,IENB
+4 QUIT
