Index: WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m
===================================================================
--- WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m	(revision 613)
+++ WorldVistAEHR/trunk/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29GA.m	(revision 623)
@@ -1,64 +1,63 @@
-RMPR29GA	;PHX/JLT,RVD,SPS-RMPR29 CONTINUED [ 09/29/94  11:22 AM ]
-	;;3.0;PROSTHETICS;**75,60,142**;Feb 09, 1996;Build 2
-	; Developed form RMPR29A for the GUI application
-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 NOLC=1 S RMHRWO=$P(^RMPR(664.1,RMPRDA,0),U,13)
-	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
-	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) D
-	.S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2),RMHTECH=$P($G(^(2)),U,3)
-	.;Changed .01 and 1 fields to create date DT below 5/25/06 for 75 SPS
-	.I RDA,'$D(^RMPR(660,RDA,0)) S RDA=""
-	.I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=DT D FILE^DICN K DLAYGO Q:+Y'>0  S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=DT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=DT
-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///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT;4.92////^S X=RMHTECH"
-	.S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA)
-	.;Set OIF/OEF field
-	.S DFN=RMPRDFN D SVC^VADPT
-	.S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
-	.I RMPROEOI="<!>" S $P(^RMPR(660,RDA,5),U,1)=1
-	.S $P(^RMPR(660,RDA,0),U,6)=IT
-	.I $P(^RMPR(660,RDA,0),U,27)="" S $P(^(0),U,27)=DUZ
-	.S $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 NOLC=1 S $P(^RMPR(660,RDA,"LB"),U,2)=RMHRWO
-	.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 S $P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(660,DA,0),U,14)="V" S $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 EN4^RMPR29U(RMPRDA)
-	Q
-END	L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J)
-	W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Process another 2529-3" D ^DIR G:+Y=1 PRC^RMPR29S
-	N RMPR,RMPRSITE D KILL^XUSCLEAN Q
-ITM	;EDIT 2529-3 ITEM
-	W ! K DIC,Y,RDA S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,",DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML",DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)" D ^DIC G:+Y'>0 PT
-	S (IEN,DA)=+Y,RNEW=$P(Y,U,3) S RY=$P(Y,U,2) D ITA^RMPR29U(RY)
-	S RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0) K RMPRPU I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AF",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1
-	I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AR4",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1
-	S DIE=DIC,DR=$S($D(RMPRPU):"",1:".01R")
-	S DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12"
-	D ^DIE I $D(DA),'$D(Y(0)) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U) D ITA^RMPR29U(RY)
-	I $D(DA),^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA) S REDIT=1,RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA) K RDATA,RMTYPE,RMCPT
-	I $D(DA) I $P(^RMPR(664.1,DA(1),2,DA,0),U)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S DIK=DIE D ^DIK D
-	.K DA W !!,?5,$C(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..."
-	I '$D(DA) S DA=$P(RDA(IEN),U,5),DIK="^RMPR(660," I +DA D ^DIK S DA=$O(^RMPR(664.2,"C",+$P(RDA(IEN),U,5),0)) I +DA S DIK="^RMPR(664.2," D ^DIK D
-	.F DA=0:0 S DA=$O(^RMPR(664.3,"C",$P(RDA(IEN),U,5),DA)) Q:DA'>0  S DIK="^RMPR(664.3," D ^DIK
-	K FLGG,DR,Y I $P($G(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($P($G(^(0)),U,4)="") D
-	.W !!,$C(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///@;.09///@;15///@;16///^S X=""CA""" D ^DIE S $P(^RMPR(664.1,DA,0),U,20)="",FLGG=1
-	K DR S RDC=$G(^RMPR(664.1,RMPRDA,2,IEN,0)) I (+RDC'=+RDA(IEN)),'RNEW D  I $D(FLGG) G END
-	.D NOW^%DTC S (NX,X)=% K %
-	.S DIC("P")="664.129DA",DA(1)=RMPRDA
-	.S DIC="^RMPR(664.1,"_RMPRDA_",8,",DIC(0)="LZ"
-	.S DLAYGO=664.1 D FILE^DICN K DLAYGO
-	.I +Y S DIE="^RMPR(664.1,"_RMPRDA_",8,",DA(1)=RMPRDA,DA=+Y,DR=".01///^S X=NX;1///^S X=$$ITM^RMPR31U(+RDA(IEN));2///^S X=$$ITM^RMPR31U(+RDC);3////^S X=DUZ;W $C(7),!!,?5,""ITEM/JOB HAS BEEN CHANGED OR DELETED"";4~AUDIT REMARKS" D ^DIE
-	G ITM
-PT	D:$D(REDIT) POST K DA,DR,REDIT G DISP^RMPR29D
-	Q
-	K DIE,DIK,DIR,ELS,HCPCS,IEN,IT,NOAC,NOLC,NX,QTY,RA,RDC,RIT,RMHRWO
-	K RMHTECH,RMPRDA,RMPRDFN,RMPRDT,RMPRG,RN,RW,RY,SCAT,SER,SRC,TO,TYP,UN,X
+RMPR29GA ;PHX/JLT,RVD,SPS-RMPR29 CONTINUED [ 09/29/94  11:22 AM ]
+ ;;3.0;PROSTHETICS;**75,60**;Feb 09, 1996;Build 18
+ ; Developed form RMPR29A for the GUI application
+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 NOLC=1 S RMHRWO=$P(^RMPR(664.1,RMPRDA,0),U,13)
+ 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
+ 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) D
+ .S HCPCS=$P($G(^RMPR(664.1,RMPRDA,2,RA,2)),U,1),RMCPT=$P($G(^(2)),U,2),RMHTECH=$P($G(^(2)),U,3)
+ .;Changed .01 and 1 fields to create date DT below 5/25/06 for 75 SPS
+ .I 'RDA S DIC="^RMPR(660,",DLAYGO=660,DIC(0)="LZ",X=DT D FILE^DICN K DLAYGO Q:+Y'>0  S RDA=+Y,RNEW=$P(Y,U,3) S $P(^RMPR(660,RDA,0),U,1)=DT,$P(^(0),U,2)=RMPRDFN,$P(^(0),U,3)=DT
+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///^S X=4;62///^S X=ELS;63///^S X=SCAT;68///^S X=RMPRG;4.1////^S X=$P(^RMPR(661.1,HCPCS,0),U,4);4.7////^S X=RMCPT;4.92////^S X=RMHTECH"
+ .S DIE="^RMPR(660,",DA=RDA D ^DIE S RIT=$P(^RMPR(660,RDA,0),U,6) K ^RMPR(660,"AD",+RIT,RDA)
+ .;Set OIF/OEF field
+ .S DFN=RMPRDFN D SVC^VADPT
+ .S RMPROEOI=$S(VASV(11)>0:"<!>",VASV(12)>0:"<!>",VASV(13)>0:"<!>",1:0)
+ .I RMPROEOI="<!>" S $P(^RMPR(660,RDA,5),U,1)=1
+ .S $P(^RMPR(660,RDA,0),U,6)=IT
+ .I $P(^RMPR(660,RDA,0),U,27)="" S $P(^(0),U,27)=DUZ
+ .S $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 NOLC=1 S $P(^RMPR(660,RDA,"LB"),U,2)=RMHRWO
+ .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 S $P(^RMPR(660,DA,"LB"),U,10)=RMPRDA,$P(^RMPR(660,DA,0),U,14)="V" S $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 EN4^RMPR29U(RMPRDA)
+ Q
+END L:+$G(RMPRDA) -^RMPR(664.1,+RMPRDA,0) K ^UTILITY("DIQ1",$J)
+ W !! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Would you like to Process another 2529-3" D ^DIR G:+Y=1 PRC^RMPR29S
+ N RMPR,RMPRSITE D KILL^XUSCLEAN Q
+ITM ;EDIT 2529-3 ITEM
+ W ! K DIC,Y,RDA S DA=RMPRDA,DIC="^RMPR(664.1,"_RMPRDA_",2,",DIC("P")="664.16PA",DA(1)=RMPRDA,DIC(0)="AEQML",DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)" D ^DIC G:+Y'>0 PT
+ S (IEN,DA)=+Y,RNEW=$P(Y,U,3) S RY=$P(Y,U,2) D ITA^RMPR29U(RY)
+ S RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0) K RMPRPU I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AF",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1
+ I $P(RDA(IEN),U,5),$D(^RMPR(664.2,"AR4",$P(RDA(IEN),U,5))) W $C(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM" S RMPRPU=1
+ S DIE=DIC,DR=$S($D(RMPRPU):"",1:".01R")
+ S DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12"
+ D ^DIE I $D(DA),'$D(Y(0)) S RY=$P(^RMPR(664.1,DA(1),2,DA,0),U) D ITA^RMPR29U(RY)
+ I $D(DA),^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA) S REDIT=1,RDATA=RMTYPE_"^"_RMPRDA_"^"_DA D CHKCPT^RMPR29U(RDATA) K RDATA,RMTYPE,RMCPT
+ I $D(DA) I $P(^RMPR(664.1,DA(1),2,DA,0),U)=""!($P(^(0),U,2)="")!($P(^(0),U,3)="")!($P(^(0),U,7)="")!($P(^(0),U,8)="") S DIK=DIE D ^DIK D
+ .K DA W !!,?5,$C(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..."
+ I '$D(DA) S DA=$P(RDA(IEN),U,5),DIK="^RMPR(660," I +DA D ^DIK S DA=$O(^RMPR(664.2,"C",+$P(RDA(IEN),U,5),0)) I +DA S DIK="^RMPR(664.2," D ^DIK D
+ .F DA=0:0 S DA=$O(^RMPR(664.3,"C",$P(RDA(IEN),U,5),DA)) Q:DA'>0  S DIK="^RMPR(664.3," D ^DIK
+ K FLGG,DR,Y I $P($G(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($P($G(^(0)),U,4)="") D
+ .W !!,$C(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED" S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///@;.09///@;15///@;16///^S X=""CA""" D ^DIE S $P(^RMPR(664.1,DA,0),U,20)="",FLGG=1
+ K DR S RDC=$G(^RMPR(664.1,RMPRDA,2,IEN,0)) I (+RDC'=+RDA(IEN)),'RNEW D  I $D(FLGG) G END
+ .D NOW^%DTC S (NX,X)=% K %
+ .S DIC("P")="664.129DA",DA(1)=RMPRDA
+ .S DIC="^RMPR(664.1,"_RMPRDA_",8,",DIC(0)="LZ"
+ .S DLAYGO=664.1 D FILE^DICN K DLAYGO
+ .I +Y S DIE="^RMPR(664.1,"_RMPRDA_",8,",DA(1)=RMPRDA,DA=+Y,DR=".01///^S X=NX;1///^S X=$$ITM^RMPR31U(+RDA(IEN));2///^S X=$$ITM^RMPR31U(+RDC);3////^S X=DUZ;W $C(7),!!,?5,""ITEM/JOB HAS BEEN CHANGED OR DELETED"";4~AUDIT REMARKS" D ^DIE
+ G ITM
+PT D:$D(REDIT) POST K DA,DR,REDIT G DISP^RMPR29D
+ Q
+ K DIE,DIK,DIR,ELS,HCPCS,IEN,IT,NOAC,NOLC,NX,QTY,RA,RDC,RIT,RMHRWO
+ K RMHTECH,RMPRDA,RMPRDFN,RMPRDT,RMPRG,RN,RW,RY,SCAT,SER,SRC,TO,TYP,UN,X
