- 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 Feb 18, 2025@23:58:43 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