RMPR29LA ;HIN/RVD-RMPR29 CONTINUED; 1/5/99
;;3.0;PROSTHETICS;**33**;Feb 09, 1996
POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660
I '$D(RMPRDA)!('$D(^RMPR(664.1,RMPRDA,2,0))) Q
S NOAC=$P(^RMPR(664.1,RMPRDA,0),U,23),NOLC=$P(^(0),U,20),RMPR("REF")=$P(^(0),U,4),RMPRG=$P(^(0),U,14)
I RMPRG G GGC
L +^RMPR(669.9,RMPRSITE,0):999 I $T=0 S RMPRG=DT_99 G GGC
S RMPRG=$P(^RMPR(669.9,RMPRSITE,0),U,7),RMPRG=RMPRG-1,$P(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG L -^RMPR(669.9,RMPRSITE,0)
GGC I 'NOAC W !!,?5,"Updating Patient's 10-2319"
S RMPRDT=$P(^RMPR(664.1,RMPRDA,0),U,1),RMPRDFN=$P(^(0),U,2),SRC=$P(^(0),U,11),TO=$P(^(0),U,15) K RNEW
;S RST=$S($G(RMLOC):15,$G(RMPRGIP):12,1:11)
F RA=0:0 S RA=$O(^RMPR(664.1,RMPRDA,2,RA)) Q:RA'>0 I $D(^(RA,0)) S IT=$P(^(0),U,1),QTY=$P(^(0),U,2),UN=$P(^(0),U,3),RDA=$P(^(0),U,5),TYP=$P(^(0),U,7),ELS=$P(^(0),U,8),SCAT=$P(^(0),U,9),SER=$P(^(0),U,12),HCPCS=$P($G(^(2)),U,1) D
.S RMGIP=$P(^RMPR(664.1,RMPRDA,2,RA,0),U,13)
.S RM3=$G(^RMPR(664.1,RMPRDA,2,RA,3))
.S RMSO=$P(RM3,U,1),RMVEN=$P(RM3,U,2),RMIT=$P(RM3,U,3),RMLOC=$P(RM3,U,4)
.I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=RMPRDT D FILE^DICN K DLAYGO Q:+Y'>0 S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=RMPRDT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=RMPRDT
DR .K DR S DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///15;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;"
.S DR=DR_"4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);13///^S X=$G(RMGIP)"
.S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA)
.S $P(^RMPR(660,RDA,1),U,2)=$P(^RMPR(661.1,HCPCS,0),U,2)
.MERGE ^RMPR(660,RDA,"DES")=^RMPR(661.1,HCPCS,2)
.S $P(^RMPR(660,RDA,"DES",0),U,2)=""
.S $P(^RMPR(660,RDA,0),U,14)=RMSO
.S $P(^RMPR(660,RDA,0),U,9)=RMVEN
.S $P(^RMPR(660,RDA,"LB"),U,12)=$E($G(^RMPR(664.1,RMPRDA,8,1,1,1,0)),1,40)
.S $P(^RMPR(660,RDA,0),U,6)=IT,$P(^(0),U,27)=DUZ,$P(^RMPR(660,RDA,"LB"),U,1)=RMPR("REF"),$P(^("LB"),U,3)=SRC,$P(^("LB"),U,4)=TO,$P(^("LB"),U,14)=NOLC,$P(^RMPR(660,RDA,"AM"),U,2)=NOAC
.I $D(^RMPR(664.1,RMPRDA,2,RA,1)),$O(^RMPR(664.1,RMPRDA,2,RA,1,0)) D
..K ^RMPR(660,RDA,"DES") F RW=0:0 S RW=$O(^RMPR(664.1,RMPRDA,2,RA,1,RW)) Q:RW'>0 S RN=RW S ^RMPR(660,RDA,"DES",RW,0)=^RMPR(664.1,RMPRDA,2,RA,1,RW,0)
.I $D(RN) S ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^"
.S DIK="^RMPR(660,",DA=RDA D:'$D(RNEW) IX^DIK D:$D(RNEW) IX1^DIK K RNEW
.S $P(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA,$P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG
S DA=RMPRDA,DIK="^RMPR(664.1," D IX^DIK I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA") D:'$D(^RMPR(664.2,"B",RMPRWO)) EN4^RMPR29LU
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29LA 2701 printed Apr 09, 2024@21:39:01 Page 2
RMPR29LA ;HIN/RVD-RMPR29 CONTINUED; 1/5/99
+1 ;;3.0;PROSTHETICS;**33**;Feb 09, 1996
POST ;POST 2529-3 TO APPLIANCE/REPAIR FILE #660
+1 IF '$DATA(RMPRDA)!('$DATA(^RMPR(664.1,RMPRDA,2,0)))
QUIT
+2 SET NOAC=$PIECE(^RMPR(664.1,RMPRDA,0),U,23)
SET NOLC=$PIECE(^(0),U,20)
SET RMPR("REF")=$PIECE(^(0),U,4)
SET RMPRG=$PIECE(^(0),U,14)
+3 IF RMPRG
GOTO GGC
+4 LOCK +^RMPR(669.9,RMPRSITE,0):999
IF $TEST=0
SET RMPRG=DT_99
GOTO GGC
+5 SET RMPRG=$PIECE(^RMPR(669.9,RMPRSITE,0),U,7)
SET RMPRG=RMPRG-1
SET $PIECE(^RMPR(669.9,RMPRSITE,0),U,7)=RMPRG
LOCK -^RMPR(669.9,RMPRSITE,0)
GGC IF 'NOAC
WRITE !!,?5,"Updating Patient's 10-2319"
+1 SET RMPRDT=$PIECE(^RMPR(664.1,RMPRDA,0),U,1)
SET RMPRDFN=$PIECE(^(0),U,2)
SET SRC=$PIECE(^(0),U,11)
SET TO=$PIECE(^(0),U,15)
KILL RNEW
+2 ;S RST=$S($G(RMLOC):15,$G(RMPRGIP):12,1:11)
+3 FOR RA=0:0
SET RA=$ORDER(^RMPR(664.1,RMPRDA,2,RA))
if RA'>0
QUIT
IF $DATA(^(RA,0))
SET IT=$PIECE(^(0),U,1)
SET QTY=$PIECE(^(0),U,2)
SET UN=$PIECE(^(0),U,3)
SET RDA=$PIECE(^(0),U,5)
SET TYP=$PIECE(^(0),U,7)
SET ELS=$PIECE(^(0),U,8)
SET SCAT=$PIECE(^(0),U,9)
SET SER=$PIECE(^(0),U,12)
SET HCPCS=$PIECE($GET(^(2)),U,1)
Begin DoDot:1
+4 SET RMGIP=$PIECE(^RMPR(664.1,RMPRDA,2,RA,0),U,13)
+5 SET RM3=$GET(^RMPR(664.1,RMPRDA,2,RA,3))
+6 SET RMSO=$PIECE(RM3,U,1)
SET RMVEN=$PIECE(RM3,U,2)
SET RMIT=$PIECE(RM3,U,3)
SET RMLOC=$PIECE(RM3,U,4)
+7 IF 'RDA
SET DIC="^RMPR(660,"
SET DLAYGO=660
SET DIC(0)="LZ"
SET X=RMPRDT
DO FILE^DICN
KILL DLAYGO
if +Y'>0
QUIT
SET RDA=+Y
SET RNEW=$PIECE(Y,U,3)
SET $PIECE(^RMPR(660,RDA,0),U,1)=RMPRDT
SET $PIECE(^(0),U,2)=RMPRDFN
SET $PIECE(^(0),U,3)=RMPRDT
DR KILL DR
SET DR="2///^S X=TYP;4.5////^S X=$G(HCPCS);5///^S X=QTY;9///^S X=SER;78///^S X=UN;8////^S X=RMPR(""STA"");11///15;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;"
+1 SET DR=DR_"4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);13///^S X=$G(RMGIP)"
+2 SET DIE="^RMPR(660,"
SET DA=RDA
DO ^DIE
SET RIT=$PIECE(^RMPR(660,RDA,0),U,6)
KILL ^RMPR(660,"AD",+RIT,RDA)
+3 SET $PIECE(^RMPR(660,RDA,1),U,2)=$PIECE(^RMPR(661.1,HCPCS,0),U,2)
+4 MERGE ^RMPR(660,RDA,"DES")=^RMPR(661.1,HCPCS,2)
+5 SET $PIECE(^RMPR(660,RDA,"DES",0),U,2)=""
+6 SET $PIECE(^RMPR(660,RDA,0),U,14)=RMSO
+7 SET $PIECE(^RMPR(660,RDA,0),U,9)=RMVEN
+8 SET $PIECE(^RMPR(660,RDA,"LB"),U,12)=$EXTRACT($GET(^RMPR(664.1,RMPRDA,8,1,1,1,0)),1,40)
+9 SET $PIECE(^RMPR(660,RDA,0),U,6)=IT
SET $PIECE(^(0),U,27)=DUZ
SET $PIECE(^RMPR(660,RDA,"LB"),U,1)=RMPR("REF")
SET $PIECE(^("LB"),U,3)=SRC
SET $PIECE(^("LB"),U,4)=TO
SET $PIECE(^("LB"),U,14)=NOLC
SET $PIECE(^RMPR(660,RDA,"AM"),U,2)=NOAC
+10 IF $DATA(^RMPR(664.1,RMPRDA,2,RA,1))
IF $ORDER(^RMPR(664.1,RMPRDA,2,RA,1,0))
Begin DoDot:2
+11 KILL ^RMPR(660,RDA,"DES")
FOR RW=0:0
SET RW=$ORDER(^RMPR(664.1,RMPRDA,2,RA,1,RW))
if RW'>0
QUIT
SET RN=RW
SET ^RMPR(660,RDA,"DES",RW,0)=^RMPR(664.1,RMPRDA,2,RA,1,RW,0)
End DoDot:2
+12 IF $DATA(RN)
SET ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^"
+13 SET DIK="^RMPR(660,"
SET DA=RDA
if '$DATA(RNEW)
DO IX^DIK
if $DATA(RNEW)
DO IX1^DIK
KILL RNEW
+14 SET $PIECE(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA
SET $PIECE(^RMPR(660,DA,"LB"),U,10)=RMPRDA
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG
End DoDot:1
+15 SET DA=RMPRDA
SET DIK="^RMPR(664.1,"
DO IX^DIK
IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")
if '$DATA(^RMPR(664.2,"B",RMPRWO))
DO EN4^RMPR29LU
+16 QUIT
