source: FOIAVistA/tag/r/PROSTHETICS-RMPR-RMPO-RMPS/RMPR29A.m

RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94  11:22 AM ]
 ;;3.0;PROSTHETICS;**12,13,28,41**;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
 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)
 .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///^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"
 .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,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 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_";13;2R;3R;8R;9R;I $P(^RMPR(664.1,DA(1),2,DA,0),U,10)'=4 S Y=""@1"";10///@;10R;@1;7;12"
 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