RMPRKIL ;JLT/PHX-REMOVE PROSTHETICS LOAN PROGRAM ;08/12/1994
;;3.0;PROSTHETICS;;Feb 09, 1996
F RMPRL=0:0 S RMPRL=$O(^RMPR(660.1,RMPRL)) Q:RMPRL'>0 I $D(^RMPR(660.1,RMPRL,0)),$P(^(0),U,9)=1 S DIK="^RMPR(660.1,",DA=RMPRL D ^DIK
K ^RMPR(660.1,"AF"),^RMPR(660.1,"AG"),DA,DIK
F DA=.05,6,7,8,9,12,19,21,22 S DA(1)="660.1",DIK="^DD(660.1," D ^DIK
S DIU=660.18,DIU(0)="S" D EN^DIU2
K DA,DIK S DIK="^RMPR(660.2," D IXALL^DIK
S DIU="^RMPR(660.2,",DIU(0)="D" D EN^DIU2 K DIU
OPT F OPT="RMPR LOAN DEL","RMPR LOAN CREATE","RMPR LOAN RET","RMPR LOAN DISP","RMPR LOAN FOLLOW-UP","RMPR LOAN PRINT ALL","RMPR LOAN EDIT","RMPR LOAN STAT","RMPR LOAN MENU" D
.F REN=0:0 S REN=$O(^DIC(19,"B",OPT,REN)) Q:REN'>0 S DA=REN,DIK="^DIC(19," D ^DIK K DA,DIK
EXIT D KILL^XUSCLEAN Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRKIL 774 printed Nov 22, 2024@17:44:58 Page 2
RMPRKIL ;JLT/PHX-REMOVE PROSTHETICS LOAN PROGRAM ;08/12/1994
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
+2 FOR RMPRL=0:0
SET RMPRL=$ORDER(^RMPR(660.1,RMPRL))
if RMPRL'>0
QUIT
IF $DATA(^RMPR(660.1,RMPRL,0))
IF $PIECE(^(0),U,9)=1
SET DIK="^RMPR(660.1,"
SET DA=RMPRL
DO ^DIK
+3 KILL ^RMPR(660.1,"AF"),^RMPR(660.1,"AG"),DA,DIK
+4 FOR DA=.05,6,7,8,9,12,19,21,22
SET DA(1)="660.1"
SET DIK="^DD(660.1,"
DO ^DIK
+5 SET DIU=660.18
SET DIU(0)="S"
DO EN^DIU2
+6 KILL DA,DIK
SET DIK="^RMPR(660.2,"
DO IXALL^DIK
+7 SET DIU="^RMPR(660.2,"
SET DIU(0)="D"
DO EN^DIU2
KILL DIU
OPT FOR OPT="RMPR LOAN DEL","RMPR LOAN CREATE","RMPR LOAN RET","RMPR LOAN DISP","RMPR LOAN FOLLOW-UP","RMPR LOAN PRINT ALL","RMPR LOAN EDIT","RMPR LOAN STAT","RMPR LOAN MENU"
Begin DoDot:1
+1 FOR REN=0:0
SET REN=$ORDER(^DIC(19,"B",OPT,REN))
if REN'>0
QUIT
SET DA=REN
SET DIK="^DIC(19,"
DO ^DIK
KILL DA,DIK
End DoDot:1
EXIT DO KILL^XUSCLEAN
QUIT
