- 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 Feb 18, 2025@23:58:16 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