RMPR29GU ;HOIFO/SPS-CREATE 2529-3 GUI [ 10/17/05 8:55 AM ]
;;3.0;PROSTHETICS;**75,144**;Feb 09, 1996;Build 17
;
A1(RMPRDA,RMPRSITE,RMPR668,RMPRPTR) ;
D IN
Q
CR(RESULTS,RMPRDA,RMPRSITE,RMPR668,RMPRPTR) ;CREATE WORK ORDER
IN D INF^RMPRSIT
S SCR=$P(^RMPR(664.1,RMPRDA,0),U,11),RMERR=0
K RMPRTMP I $P(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA") S RMPRTMP=1
N DIC,Y,DIR S RMPRWO=1 D FQ^RMPRDT Q:'$D(RMPRFY)!('$D(RMPRQTR)) S:'$D(RMPRTMP) RMPRWO=$$STAN^RMPR31U(RMPR("STA"))_"-"_RMPRFY_"-"_RMPRQTR I $D(RMPRTMP) D
.S RMPRWO=$$STAN^RMPR31U($P(^RMPR(664.1,RMPRDA,0),U,15))_"T-"_RMPRFY_"-"_RMPRQTR
I '$D(^RMPR(669.1,"B",RMPRWO)) K DD,D0 S DIC="^RMPR(669.1,",DLAYGO=669.1,DIC(0)="LZ",X=RMPRWO D FILE^DICN K DLAYGO,D0
S RDA=$O(^RMPR(669.1,"B",RMPRWO,0)) Q:'RDA
L +^RMPR(669.1,RDA,0):1 I '$T S RESULTS(0)="1^Someone is editing this record!" G EXIT
S RN=$P(^RMPR(669.1,RDA,0),U,2)+1 F I=1:1:4-$L(RN) S RN="0"_RN
S RMPRWO=RMPRWO_"-"_SCR_"-"_RN
S $P(^RMPR(669.1,RDA,0),U,2)=RN L -^RMPR(669.1,RDA,0)
S $P(^RMPR(664.1,RMPRDA,0),U,13)=$G(RMPRWO)
;set no admin count/no lab count
I $P(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")&($P(^(0),U,4)'=RMPR("STA")) S $P(^(0),U,23)=1
I $P(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA") S $P(^(0),U,20)=1 S:$D(RMPR25) $P(^RMPR(664.1,RMPRDA,0),U,23)=1 S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""PC""" D ^DIE
I '$P(^RMPR(664.1,RMPRDA,0),U,20) S DIE="^RMPR(664.1,",DA=RMPRDA,DR="16///^S X=""P""" D ^DIE
S RMDAT(664.1,RMPRDA_",",13)=DUZ
S RMDAT(664.1,RMPRDA_",",17)=DT
S RMDAT(664.1,RMPRDA_",",.05)=RMPR668
D FILE^DIE("","RMDAT","RMERROR")
I $D(RMERROR) S RMERR=1 D ERR G EXIT
D IN5^VADPT S VAINDT=$P($G(VAIP(3)),U) D INP^VADPT
I VAIN(1) S DR="12//^S X=$P(VAIN(4),U,2)" D ^DIE
S RMSOP=$S($P(^RMPR(664.1,RMPRDA,0),U,11)="O":11,$P(^(0),U,11)="E":11,$P(^(0),U,11)="R":11,$P(^(0),U,11)="W":11,1:"")
I +RMSOP>0 D G:RMERR=1 EXIT
.L +^RMPR(668,RMPR668):2
.I $T=0 S RESULTS(0)="1^Someone else is Editing this entry!" S RMERR=1 Q
.S RMDAT(668,RMPR668_",",9)=RMSOP
.D FILE^DIE("","RMDAT","RMERROR")
.L -^RMPR(668,RMPR668)
.I $D(RMERROR) S RMERR=1 D ERR Q
D ^RMPR29GA
S RESULTS(0)=0_"^"_"Work Order Created: "_RMPRWO
;ADD PRINT HERE.
I RMPRPTR=0 D PRT^RMPR29R
I +RMPRPTR D EN1^RMPR29R(RMPRPTR)
Q
ERR ;QUIT ON ERROR
S RESULTS(0)="1^The following error has occured "_RMERROR
Q
EXIT ;
K DA,DIE,DR,I,RDA,RMDAT,RMERR,RMERROR,RMPR,RMPR25,RMPRFY,RMPRQTR,RMPRWO
K RMSOP,RN,SCR,VAIN,VAINDT,VAIP,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29GU 2487 printed Apr 09, 2024@21:37:54 Page 2
RMPR29GU ;HOIFO/SPS-CREATE 2529-3 GUI [ 10/17/05 8:55 AM ]
+1 ;;3.0;PROSTHETICS;**75,144**;Feb 09, 1996;Build 17
+2 ;
A1(RMPRDA,RMPRSITE,RMPR668,RMPRPTR) ;
+1 DO IN
+2 QUIT
CR(RESULTS,RMPRDA,RMPRSITE,RMPR668,RMPRPTR) ;CREATE WORK ORDER
IN DO INF^RMPRSIT
+1 SET SCR=$PIECE(^RMPR(664.1,RMPRDA,0),U,11)
SET RMERR=0
+2 KILL RMPRTMP
IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA")
SET RMPRTMP=1
+3 NEW DIC,Y,DIR
SET RMPRWO=1
DO FQ^RMPRDT
if '$DATA(RMPRFY)!('$DATA(RMPRQTR))
QUIT
if '$DATA(RMPRTMP)
SET RMPRWO=$$STAN^RMPR31U(RMPR("STA"))_"-"_RMPRFY_"-"_RMPRQTR
IF $DATA(RMPRTMP)
Begin DoDot:1
+4 SET RMPRWO=$$STAN^RMPR31U($PIECE(^RMPR(664.1,RMPRDA,0),U,15))_"T-"_RMPRFY_"-"_RMPRQTR
End DoDot:1
+5 IF '$DATA(^RMPR(669.1,"B",RMPRWO))
KILL DD,D0
SET DIC="^RMPR(669.1,"
SET DLAYGO=669.1
SET DIC(0)="LZ"
SET X=RMPRWO
DO FILE^DICN
KILL DLAYGO,D0
+6 SET RDA=$ORDER(^RMPR(669.1,"B",RMPRWO,0))
if 'RDA
QUIT
+7 LOCK +^RMPR(669.1,RDA,0):1
IF '$TEST
SET RESULTS(0)="1^Someone is editing this record!"
GOTO EXIT
+8 SET RN=$PIECE(^RMPR(669.1,RDA,0),U,2)+1
FOR I=1:1:4-$LENGTH(RN)
SET RN="0"_RN
+9 SET RMPRWO=RMPRWO_"-"_SCR_"-"_RN
+10 SET $PIECE(^RMPR(669.1,RDA,0),U,2)=RN
LOCK -^RMPR(669.1,RDA,0)
+11 SET $PIECE(^RMPR(664.1,RMPRDA,0),U,13)=$GET(RMPRWO)
+12 ;set no admin count/no lab count
+13 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)=RMPR("STA")&($PIECE(^(0),U,4)'=RMPR("STA"))
SET $PIECE(^(0),U,23)=1
+14 IF $PIECE(^RMPR(664.1,RMPRDA,0),U,15)'=RMPR("STA")
SET $PIECE(^(0),U,20)=1
if $DATA(RMPR25)
SET $PIECE(^RMPR(664.1,RMPRDA,0),U,23)=1
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""PC"""
DO ^DIE
+15 IF '$PIECE(^RMPR(664.1,RMPRDA,0),U,20)
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="16///^S X=""P"""
DO ^DIE
+16 SET RMDAT(664.1,RMPRDA_",",13)=DUZ
+17 SET RMDAT(664.1,RMPRDA_",",17)=DT
+18 SET RMDAT(664.1,RMPRDA_",",.05)=RMPR668
+19 DO FILE^DIE("","RMDAT","RMERROR")
+20 IF $DATA(RMERROR)
SET RMERR=1
DO ERR
GOTO EXIT
+21 DO IN5^VADPT
SET VAINDT=$PIECE($GET(VAIP(3)),U)
DO INP^VADPT
+22 IF VAIN(1)
SET DR="12//^S X=$P(VAIN(4),U,2)"
DO ^DIE
+23 SET RMSOP=$SELECT($PIECE(^RMPR(664.1,RMPRDA,0),U,11)="O":11,$PIECE(^(0),U,11)="E":11,$PIECE(^(0),U,11)="R":11,$PIECE(^(0),U,11)="W":11,1:"")
+24 IF +RMSOP>0
Begin DoDot:1
+25 LOCK +^RMPR(668,RMPR668):2
+26 IF $TEST=0
SET RESULTS(0)="1^Someone else is Editing this entry!"
SET RMERR=1
QUIT
+27 SET RMDAT(668,RMPR668_",",9)=RMSOP
+28 DO FILE^DIE("","RMDAT","RMERROR")
+29 LOCK -^RMPR(668,RMPR668)
+30 IF $DATA(RMERROR)
SET RMERR=1
DO ERR
QUIT
End DoDot:1
if RMERR=1
GOTO EXIT
+31 DO ^RMPR29GA
+32 SET RESULTS(0)=0_"^"_"Work Order Created: "_RMPRWO
+33 ;ADD PRINT HERE.
+34 IF RMPRPTR=0
DO PRT^RMPR29R
+35 IF +RMPRPTR
DO EN1^RMPR29R(RMPRPTR)
+36 QUIT
ERR ;QUIT ON ERROR
+1 SET RESULTS(0)="1^The following error has occured "_RMERROR
+2 QUIT
EXIT ;
+1 KILL DA,DIE,DR,I,RDA,RMDAT,RMERR,RMERROR,RMPR,RMPR25,RMPRFY,RMPRQTR,RMPRWO
+2 KILL RMSOP,RN,SCR,VAIN,VAINDT,VAIP,X
+3 QUIT
