RMPR144P.m

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 ---RMPR144P   1324     printed  Apr 09, 2024@21:37:53                                                                                                                                                                                                    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