source: FOIAVistA/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29LA.m@ 1720

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