- RMPRPS42 ;HISC/RVD - POST INIT FOR LAB TIME ENTRY; 12/8/99
- ;;3.0;PROSTHETICS;**42**;Feb 09,1996
- W !,$C(7),"Invalid Entry......"
- Q
- LABTIM ;Populate the pre-determined time from the table DAT+
- S U="^"
- W @IOF,"Entering LAB time......."
- F I=1:1 S RMDAT=$P($T(DAT+I),";",3) Q:RMDAT="" S RHCPC=$P(RMDAT,U,1),RMTIME=$P(RMDAT,U,2),RMHC=$O(^RMPR(661.1,"B",RHCPC,0)) I RMHC S:RMTIME="" RMTIME=15 S $P(^RMPR(661.1,RMHC,0),U,10)=RMTIME
- W !,"Done Entering Lab time......."
- G KILL
- ;
- INIT ;Initialize all the ITEM from SHORT DESCRIPTION
- ;
- W !!,"Start Initialization of Items......."
- S DLAYGO=661.1,DIC(0)="L"
- RET F I=0:0 S I=$O(^RMPR(661.1,I)) Q:I'>0 S RMDES=$P(^RMPR(661.1,I,0),U,2) D:RMDES'=""
- .S X=$P(RMDES," ",1),X=$E(X,1,26),X=X_"/COMMERCIAL"
- .Q:$D(^RMPR(661.1,I,3,"B"))
- .S $P(^RMPR(661.1,I,3,0),U,2)=661.12,DA(1)=I,DIC="^RMPR(661.1,"_DA(1)_",3,"
- .D FILE^DICN
- W !!,"Done Initialization of Items......."
- ;
- KILL K I,J,RMIEN,RMPAT,RMSCAT,RMFRM,RMDAT0,RMDATAM,RMCHK,RMTYP,RMGRP,RMSRC
- K RMDAT,RMHC,DA,RMDES,X,DIC,DLAYGO,R0,RH,RI,RIT,RMHCPC,RMIT,RLO,RHC
- Q
- ;
- DEL ;clean-up all line items in node 3.
- F I=0:0 S I=$O(^RMPR(661.1,I)) Q:I'>0 K ^RMPR(661.1,I,3)
- G KILL
- ;
- DAT ;;table for lab pre-determined time
- ;;L4350
- ;;L1902
- ;;L8230
- ;;L0940
- ;;E0191
- ;;L4360
- ;;L0100
- ;;L0172
- ;;L0120
- ;;L0140
- ;;L0500
- ;;E0110
- ;;E0112
- ;;E0240
- ;;A4927
- ;;L3050
- ;;A4500
- ;;L8130
- ;;L8100
- ;;L8210
- ;;L8150
- ;;L8120
- ;;L8190
- ;;L1830
- ;;A4565
- ;;L1832
- ;;L5667
- ;;L4310
- ;;L0520
- ;;E0191
- ;;L3999
- ;;L2999
- ;;L3221
- ;;L0120
- ;;L1825
- ;;L1810
- ;;L3700
- ;;L0370
- ;;L3980
- ;;L3908
- ;;L3660
- ;;L5674
- ;;L0430
- ;;L8300
- ;;E0152
- ;;E0150
- ;;L1804
- ;;L1930^90
- ;;L1845^60
- ;;L0810^60
- ;;L1680^60
- ;;L0520^45
- ;;L1832^45
- ;;L0190^45
- ;;L0430^60
- ;;L0370^45
- ;;E0443^30
- ;;L3010^90
- ;;L3040^45
- ;;L3310^45
- ;;L3003^30
- ;;L3002^45
- ;;L3003
- ;;L3332^30
- ;;L3265
- ;;L3260
- ;;L3250^90
- ;;L3230^90
- ;;L3221^45
- ;;L3253^45
- ;;L3216^45
- ;;L3420^45
- ;;L3649
- ;;L5450^60
- ;;L8410
- ;;L8400
- ;;L8460
- ;;L8440
- ;;L8430
- ;;L8417
- ;;L8420
- ;;L5662^30
- ;;L5675^30
- ;;L7510^30
- ;;E0100
- ;;K0108
- ;;L1660
- ;;L3800
- ;;L3930
- ;;A4637
- ;;E0151
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPS42 2236 printed Apr 23, 2025@18:51:59 Page 2
- RMPRPS42 ;HISC/RVD - POST INIT FOR LAB TIME ENTRY; 12/8/99
- +1 ;;3.0;PROSTHETICS;**42**;Feb 09,1996
- +2 WRITE !,$CHAR(7),"Invalid Entry......"
- +3 QUIT
- LABTIM ;Populate the pre-determined time from the table DAT+
- +1 SET U="^"
- +2 WRITE @IOF,"Entering LAB time......."
- +3 FOR I=1:1
- SET RMDAT=$PIECE($TEXT(DAT+I),";",3)
- if RMDAT=""
- QUIT
- SET RHCPC=$PIECE(RMDAT,U,1)
- SET RMTIME=$PIECE(RMDAT,U,2)
- SET RMHC=$ORDER(^RMPR(661.1,"B",RHCPC,0))
- IF RMHC
- if RMTIME=""
- SET RMTIME=15
- SET $PIECE(^RMPR(661.1,RMHC,0),U,10)=RMTIME
- +4 WRITE !,"Done Entering Lab time......."
- +5 GOTO KILL
- +6 ;
- INIT ;Initialize all the ITEM from SHORT DESCRIPTION
- +1 ;
- +2 WRITE !!,"Start Initialization of Items......."
- +3 SET DLAYGO=661.1
- SET DIC(0)="L"
- RET FOR I=0:0
- SET I=$ORDER(^RMPR(661.1,I))
- if I'>0
- QUIT
- SET RMDES=$PIECE(^RMPR(661.1,I,0),U,2)
- if RMDES'=""
- Begin DoDot:1
- +1 SET X=$PIECE(RMDES," ",1)
- SET X=$EXTRACT(X,1,26)
- SET X=X_"/COMMERCIAL"
- +2 if $DATA(^RMPR(661.1,I,3,"B"))
- QUIT
- +3 SET $PIECE(^RMPR(661.1,I,3,0),U,2)=661.12
- SET DA(1)=I
- SET DIC="^RMPR(661.1,"_DA(1)_",3,"
- +4 DO FILE^DICN
- End DoDot:1
- +5 WRITE !!,"Done Initialization of Items......."
- +6 ;
- KILL KILL I,J,RMIEN,RMPAT,RMSCAT,RMFRM,RMDAT0,RMDATAM,RMCHK,RMTYP,RMGRP,RMSRC
- +1 KILL RMDAT,RMHC,DA,RMDES,X,DIC,DLAYGO,R0,RH,RI,RIT,RMHCPC,RMIT,RLO,RHC
- +2 QUIT
- +3 ;
- DEL ;clean-up all line items in node 3.
- +1 FOR I=0:0
- SET I=$ORDER(^RMPR(661.1,I))
- if I'>0
- QUIT
- KILL ^RMPR(661.1,I,3)
- +2 GOTO KILL
- +3 ;
- DAT ;;table for lab pre-determined time
- +1 ;;L4350
- +2 ;;L1902
- +3 ;;L8230
- +4 ;;L0940
- +5 ;;E0191
- +6 ;;L4360
- +7 ;;L0100
- +8 ;;L0172
- +9 ;;L0120
- +10 ;;L0140
- +11 ;;L0500
- +12 ;;E0110
- +13 ;;E0112
- +14 ;;E0240
- +15 ;;A4927
- +16 ;;L3050
- +17 ;;A4500
- +18 ;;L8130
- +19 ;;L8100
- +20 ;;L8210
- +21 ;;L8150
- +22 ;;L8120
- +23 ;;L8190
- +24 ;;L1830
- +25 ;;A4565
- +26 ;;L1832
- +27 ;;L5667
- +28 ;;L4310
- +29 ;;L0520
- +30 ;;E0191
- +31 ;;L3999
- +32 ;;L2999
- +33 ;;L3221
- +34 ;;L0120
- +35 ;;L1825
- +36 ;;L1810
- +37 ;;L3700
- +38 ;;L0370
- +39 ;;L3980
- +40 ;;L3908
- +41 ;;L3660
- +42 ;;L5674
- +43 ;;L0430
- +44 ;;L8300
- +45 ;;E0152
- +46 ;;E0150
- +47 ;;L1804
- +48 ;;L1930^90
- +49 ;;L1845^60
- +50 ;;L0810^60
- +51 ;;L1680^60
- +52 ;;L0520^45
- +53 ;;L1832^45
- +54 ;;L0190^45
- +55 ;;L0430^60
- +56 ;;L0370^45
- +57 ;;E0443^30
- +58 ;;L3010^90
- +59 ;;L3040^45
- +60 ;;L3310^45
- +61 ;;L3003^30
- +62 ;;L3002^45
- +63 ;;L3003
- +64 ;;L3332^30
- +65 ;;L3265
- +66 ;;L3260
- +67 ;;L3250^90
- +68 ;;L3230^90
- +69 ;;L3221^45
- +70 ;;L3253^45
- +71 ;;L3216^45
- +72 ;;L3420^45
- +73 ;;L3649
- +74 ;;L5450^60
- +75 ;;L8410
- +76 ;;L8400
- +77 ;;L8460
- +78 ;;L8440
- +79 ;;L8430
- +80 ;;L8417
- +81 ;;L8420
- +82 ;;L5662^30
- +83 ;;L5675^30
- +84 ;;L7510^30
- +85 ;;E0100
- +86 ;;K0108
- +87 ;;L1660
- +88 ;;L3800
- +89 ;;L3930
- +90 ;;A4637
- +91 ;;E0151
