RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94 11:22 AM ]
;;3.0;PROSTHETICS;**12,13,28,41,142**;Feb 09, 1996;Build 2
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,'$D(^RMPR(660,RDA,0)) S RDA=""
.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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29A 4786 printed Jan 18, 2025@03:33:12 Page 2
RMPR29A ;PHX/JLT,RVD-RMPR29 CONTINUED [ 09/29/94 11:22 AM ]
+1 ;;3.0;PROSTHETICS;**12,13,28,41,142**;Feb 09, 1996;Build 2
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 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)
Begin DoDot:1
+3 SET HCPCS=$PIECE($GET(^RMPR(664.1,RMPRDA,2,RA,2)),U,1)
SET RMCPT=$PIECE($GET(^(2)),U,2)
+4 IF RDA
IF '$DATA(^RMPR(660,RDA,0))
SET RDA=""
+5 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///^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"
+1 SET DIE="^RMPR(660,"
SET DA=RDA
DO ^DIE
SET RIT=$PIECE(^RMPR(660,RDA,0),U,6)
KILL ^RMPR(660,"AD",+RIT,RDA)
+2 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
+3 IF $DATA(^RMPR(664.1,RMPRDA,2,RA,1))
IF $ORDER(^RMPR(664.1,RMPRDA,2,RA,1,0))
Begin DoDot:2
+4 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
+5 IF $DATA(RN)
SET ^RMPR(660,RDA,"DES",0)="^660.028^"_RN_U_RN_U_DT_"^^"
+6 SET DIK="^RMPR(660,"
SET DA=RDA
if '$DATA(RNEW)
DO IX^DIK
if $DATA(RNEW)
DO IX1^DIK
KILL RNEW
+7 SET $PIECE(^RMPR(664.1,RMPRDA,2,RA,0),U,5)=RDA
SET $PIECE(^RMPR(660,DA,"LB"),U,10)=RMPRDA
SET $PIECE(^RMPR(660,DA,0),U,14)="V"
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,14)=RMPRG
End DoDot:1
+8 SET DA=RMPRDA
SET DIK="^RMPR(664.1,"
DO IX^DIK
IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")
DO EN4^RMPR29U(RMPRDA)
+9 QUIT
END if +$GET(RMPRDA)
LOCK -^RMPR(664.1,+RMPRDA,0)
KILL ^UTILITY("DIQ1",$JOB)
+1 WRITE !!
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Would you like to Process another 2529-3"
DO ^DIR
if +Y=1
GOTO PRC^RMPR29S
+2 NEW RMPR,RMPRSITE
DO KILL^XUSCLEAN
QUIT
ITM ;EDIT 2529-3 ITEM
+1 WRITE !
KILL DIC,Y,RDA
SET DA=RMPRDA
SET DIC="^RMPR(664.1,"_RMPRDA_",2,"
SET DIC("P")="664.16PA"
SET DA(1)=RMPRDA
SET DIC(0)="AEQML"
SET DIC("W")="S RA=$P(^(0),U,1) W ?16,$$ITM^RMPR31U(RA)"
DO ^DIC
if +Y'>0
GOTO PT
+2 SET (IEN,DA)=+Y
SET RNEW=$PIECE(Y,U,3)
SET RY=$PIECE(Y,U,2)
DO ITA^RMPR29U(RY)
+3 SET RDA(+Y)=^RMPR(664.1,RMPRDA,2,+Y,0)
KILL RMPRPU
IF $PIECE(RDA(IEN),U,5)
IF $DATA(^RMPR(664.2,"AF",$PIECE(RDA(IEN),U,5)))
WRITE $CHAR(7),!!,?5,"A 2421 HAS BEEN INITIATED FOR THIS ITEM"
SET RMPRPU=1
+4 IF $PIECE(RDA(IEN),U,5)
IF $DATA(^RMPR(664.2,"AR4",$PIECE(RDA(IEN),U,5)))
WRITE $CHAR(7),!!,?5,"A 2529-3 HAS BEEN INITIATED FOR THIS ITEM"
SET RMPRPU=1
+5 SET DIE=DIC
SET DR=$SELECT($DATA(RMPRPU):"",1:".01R")
+6 ;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"
+7 SET DR=DR_";8R;S RMTYPE=$P(^RMPR(664.1,RMPRDA,2,DA,0),U,7);9R;13;2R;3R;7;12"
+8 DO ^DIE
IF $DATA(DA)
IF '$DATA(Y(0))
SET RY=$PIECE(^RMPR(664.1,DA(1),2,DA,0),U)
DO ITA^RMPR29U(RY)
+9 IF $DATA(DA)
IF ^RMPR(664.1,DA(1),2,DA,0)'=RDA(DA)
SET REDIT=1
SET RDATA=RMTYPE_"^"_RMPRDA_"^"_DA
DO CHKCPT^RMPR29U(RDATA)
KILL RDATA,RMTYPE,RMCPT
+10 IF $DATA(DA)
IF $PIECE(^RMPR(664.1,DA(1),2,DA,0),U)=""!($PIECE(^(0),U,2)="")!($PIECE(^(0),U,3)="")!($PIECE(^(0),U,7)="")!($PIECE(^(0),U,8)="")
SET DIK=DIE
DO ^DIK
Begin DoDot:1
+11 KILL DA
WRITE !!,?5,$CHAR(7),"ITEM INFORMATION IS MISSING",!!,?5,"Deleted..."
End DoDot:1
+12 IF '$DATA(DA)
SET DA=$PIECE(RDA(IEN),U,5)
SET DIK="^RMPR(660,"
IF +DA
DO ^DIK
SET DA=$ORDER(^RMPR(664.2,"C",+$PIECE(RDA(IEN),U,5),0))
IF +DA
SET DIK="^RMPR(664.2,"
DO ^DIK
Begin DoDot:1
+13 FOR DA=0:0
SET DA=$ORDER(^RMPR(664.3,"C",$PIECE(RDA(IEN),U,5),DA))
if DA'>0
QUIT
SET DIK="^RMPR(664.3,"
DO ^DIK
End DoDot:1
+14 KILL FLGG,DR,Y
IF $PIECE($GET(^RMPR(664.1,RMPRDA,2,0)),U,3)=""!($PIECE($GET(^(0)),U,4)="")
Begin DoDot:1
+15 WRITE !!,$CHAR(7),?5,"2529-3 HAS BEEN RETURNED CANCELLED"
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="19///@;.09///@;15///@;16///^S X=""CA"""
DO ^DIE
SET $PIECE(^RMPR(664.1,DA,0),U,20)=""
SET FLGG=1
End DoDot:1
+16 KILL DR
SET RDC=$GET(^RMPR(664.1,RMPRDA,2,IEN,0))
IF (+RDC'=+RDA(IEN))
IF 'RNEW
Begin DoDot:1
+17 DO NOW^%DTC
SET (NX,X)=%
KILL %
+18 SET DIC("P")="664.129DA"
SET DA(1)=RMPRDA
+19 SET DIC="^RMPR(664.1,"_RMPRDA_",8,"
SET DIC(0)="LZ"
+20 SET DLAYGO=664.1
DO FILE^DICN
KILL DLAYGO
+21 IF +Y
SET DIE="^RMPR(664.1,"_RMPRDA_",8,"
SET DA(1)=RMPRDA
SET DA=+Y
SET 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"
DO ^DIE
End DoDot:1
IF $DATA(FLGG)
GOTO END
+22 GOTO ITM
PT if $DATA(REDIT)
DO POST
KILL DA,DR,REDIT
GOTO DISP^RMPR29D
