RMPR29S ;PHX/JLT-ASSIGN WORK ORDER[ 09/30/94 3:55 PM ]
;;3.0;PROSTHETICS;**50**;Feb 09, 1996
;
;ODJ - Patch 50 - 7/13/00 - put in call to set patient vars. to
; prevent undef errs. cf nois MIW-1098-41197
;
ASK ;ASK FOR MUTLIPLE ASSGIN
D DIV4^RMPRSIT G:$D(X) EXIT
S DIR(0)="Y",DIR("A")="Would you like assign Multiple 2529-3's",DIR("B")="YES" D ^DIR G:$D(DIRUT)!($D(DTOUT)) EXIT I +Y=1 S PCOUNT=0 G MUL
APP ;ASSIGN SINGLE 2529-3 TO TECHNICIAN
S DIC="^RMPR(664.1,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,3)=RMPR(""STA""),'$P(^(0),U,20),($P(^(0),U,17)=""P""!($P(^(0),U,17)=""A""))",DIC("W")="D EN3^RMPRD1" D ^DIC G:+Y'>0 EXIT
S RMPRDA=+Y,PASS=1
ASM ;check/lock record
;S RMPRDA=+Y
Q:$G(RMPRDA)<1
L +^RMPR(664.1,RMPRDA,0):1 I '$T W !!,$C(7),?5,"Someone else is editing this entry" G EXIT
S RMPRWO=$P(^RMPR(664.1,RMPRDA,0),U,13) G DISP^RMPR29D
ATCH ;attach technician/status to record
;CALLED BY RMPR29T
;VARIABLE REQUIRED: RMPRDA - ENTRY NUMBER IN FILE 664.1
; RMPR ARRAY - MISCELLANEOUS SITE DATASET BY
; A CALL TO DIV4^RMPRSIT
; RMPR("L") - A LINE OF DIRECTIONS
K DIC,Y S DIC("B")=$S($P(^RMPR(664.1,+RMPRDA,0),U,16):$$EMP^RMPR31U($P(^(0),U,16)),1:""),DIC="^VA(200,",DIC(0)="AEQMZ",DIC("A")="LAB TECHNICIAN: " D ^DIC G:+Y'>0 EXIT S PEMP=+Y D ST^RMPR29U
S DIE="^RMPR(664.1,",DR=$S($P($G(^RMPR(664.1,RMPRDA,7)),U):"19R",1:"19R///^S X=DT"),DA=RMPRDA D ^DIE G:$D(DTOUT)!($D(Y)) EXIT
G DISP^RMPR29D
EXIT ;common exit point
;CALLED BY RMPR29T
L -^RMPR(664.1,+$G(RMPRDA),0)
K DIC,DIE,DIR,DA,DIRUT,DR,DTOUT,PEMP,PREV,PSM,RMPRDA,RMPRDFN,RMPRWO,RI
K PASS,PCOUNT Q
MUL ;MULTIPLE ASSIGN
S RMPRBAC1=1
K PDCA F RI=0:0 S RI=$O(^RMPR(664.1,"E","P",RI)) Q:+RI'>0 I +RI,$P($G(^RMPR(664.1,RI,0)),U,3)=RMPR("STA") S PDCA(RI)="",PREV(-RI)=""
I '$D(PDCA) D MESS G EXIT
S PCOUNT=$O(PDCA(PCOUNT)) G:$G(PCOUNT)<1 EXIT
I +PCOUNT S Y=PCOUNT,RMPRDA=Y,PSM=1
D ASM
Q
NEXT ;LOOK THRU EXITING 2529-3's
;CALLED BY RMPR29T
;VARIABLES REQUIRED: PDCA - AN ARRAY
; RMPRDA - ENTRY IN FILE 664
; PCOUNT - AN INDEX
; RMPR ARRAY - MISCELLANEOUS SET BY
; A CALL TO DIV4^RMPRSIT
;I +$O(PDCA(RMPRDA))=0 W $C(7) S Y=RMPRDA G ASM
;S PCOUNT=$O(PDCA(PCOUNT)) I +PCOUNT S Y=PCOUNT G ASM
I +$O(PDCA(RMPRDA))=0 W $C(7),!!,"There are no more 'next' jobs to assign." H 2 Q ;G ASM
S RMPRDA=$O(PDCA(RMPRDA)) I $G(RMPRDA)>0 G ASM
Q
PREV ;previous record
;CALLED BY RMPR29T
;VARIABLE REQUIRED: RMPRDA - SUPSCRIPT IN PREV ARRAY
; PREV - AN ARRAY
I +$O(PREV(-RMPRDA))=0 W $C(7) S Y=RMPRDA G ASM
S Y=$O(PREV(-RMPRDA)) I $G(Y)'="" S (PCOUNT,Y)=Y*-1,PSM=1,RMPRDA=Y G ASM
Q
MESS ;message/pause
W !!,$C(7),?5,"No Lab 2529-3's need to be assigned" H 3
Q
PRC ;entry point from option RMPR PROCESS 2529-3 JOB
;PROCESS 2529-3 TO CREATE WORK ORDER
;CALLED BY RMPR29A
;VARIABLES REQUIRED: NONE
D KVAR^VADPT,HOME^%ZIS K X,Y,DIC
D DIV4^RMPRSIT G:$D(X) EXIT
S DIC="^RMPR(664.1,",DIC(0)="AEQM"
;screen
;if STATION = site selected
;if WORK ORDER NUMBER not null
;if NO LAB COUNT null
;if STATUS "A" Assigned to tech
S DIC("S")="I $P(^(0),U,3)=RMPR(""STA""),$P(^(0),U,13)'="""",'$P(^(0),U,20),($P(^(0),U,17)=""A"""
S DIC("W")="D EN3^RMPRD1"
;change to screen
;if supervisor key, add to screen
;if STATUS = "R" returned to tech
;if STATUS = "PC" pending completion
;if STATUS = "P" pending assignment
;or if not supervisor key, add to screen
;if STATUS = "R"
S DIC("S")=$S($D(^XUSEC("RMPR LAB SUPERVISOR",DUZ)):DIC("S")_"!($P(^(0),U,17)=""R"")!($P(^(0),U,17)=""PC"")!($P(^(0),U,17)=""P""))",1:DIC("S")_"!($P(^(0),U,17)=""R""))")
D ^DIC S:+Y RMPRDA=+Y K DIC G:+Y'>0 EXIT
;
L +^RMPR(664.1,+Y,0):1 I '$T W !!,?5,$C(7),"Someone is already editing this entry" G EXIT
S RMPRDFN=$P(^RMPR(664.1,+Y,0),U,2) I '$P(^(0),U,16) S RMPRWO=$P(^(0),U,13)
D ;preserve value of $T
. D DPTVARS(RMPRDFN) ; set patient vars. required for display later on
. Q
I S DIR(0)="Y",DIR("A")="You are self Assigning WORK ORDER #: "_RMPRWO_" ",DIR("B")="YES"
;if TECHNICIAN null
I W !! D ^DIR G:$D(DIRUT)!($D(DTOUT))!(+Y=0) EXIT I +Y=1 D EN4^RMPR29U(RMPRDA) S PEMP=DUZ S DIE="^RMPR(664.1,",DA=RMPRDA,DR="19///^S X=DT" D ^DIE D ST^RMPR29U G DISP^RMPR29D
D EN4^RMPR29U(RMPRDA) G DISP^RMPR29D
;exit from RMPR29D
;
; Get patient vars using same code as in RMPRUTIL
DPTVARS(DFN) ;
N VADM,VAEL
D DEM^VADPT
D ELIG^VADPT
;set prosthetic variables
;rmprssn is number nnnnnnnnn
;rmprssne is external format of ssn nnn-nn-nnnn
S RMPRNAM=$P(VADM(1),U),RMPRSSN=$P(VADM(2),U)
S RMPRDOB=$P(VADM(3),U),RMPRSSNE=VA("PID")
S RMPRCNUM=VAEL(7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29S 4824 printed Apr 09, 2024@21:37:40 Page 2
RMPR29S ;PHX/JLT-ASSIGN WORK ORDER[ 09/30/94 3:55 PM ]
+1 ;;3.0;PROSTHETICS;**50**;Feb 09, 1996
+2 ;
+3 ;ODJ - Patch 50 - 7/13/00 - put in call to set patient vars. to
+4 ; prevent undef errs. cf nois MIW-1098-41197
+5 ;
ASK ;ASK FOR MUTLIPLE ASSGIN
+1 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+2 SET DIR(0)="Y"
SET DIR("A")="Would you like assign Multiple 2529-3's"
SET DIR("B")="YES"
DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))
GOTO EXIT
IF +Y=1
SET PCOUNT=0
GOTO MUL
APP ;ASSIGN SINGLE 2529-3 TO TECHNICIAN
+1 SET DIC="^RMPR(664.1,"
SET DIC(0)="AEQM"
SET DIC("S")="I $P(^(0),U,3)=RMPR(""STA""),'$P(^(0),U,20),($P(^(0),U,17)=""P""!($P(^(0),U,17)=""A""))"
SET DIC("W")="D EN3^RMPRD1"
DO ^DIC
if +Y'>0
GOTO EXIT
+2 SET RMPRDA=+Y
SET PASS=1
ASM ;check/lock record
+1 ;S RMPRDA=+Y
+2 if $GET(RMPRDA)<1
QUIT
+3 LOCK +^RMPR(664.1,RMPRDA,0):1
IF '$TEST
WRITE !!,$CHAR(7),?5,"Someone else is editing this entry"
GOTO EXIT
+4 SET RMPRWO=$PIECE(^RMPR(664.1,RMPRDA,0),U,13)
GOTO DISP^RMPR29D
ATCH ;attach technician/status to record
+1 ;CALLED BY RMPR29T
+2 ;VARIABLE REQUIRED: RMPRDA - ENTRY NUMBER IN FILE 664.1
+3 ; RMPR ARRAY - MISCELLANEOUS SITE DATASET BY
+4 ; A CALL TO DIV4^RMPRSIT
+5 ; RMPR("L") - A LINE OF DIRECTIONS
+6 KILL DIC,Y
SET DIC("B")=$SELECT($PIECE(^RMPR(664.1,+RMPRDA,0),U,16):$$EMP^RMPR31U($PIECE(^(0),U,16)),1:"")
SET DIC="^VA(200,"
SET DIC(0)="AEQMZ"
SET DIC("A")="LAB TECHNICIAN: "
DO ^DIC
if +Y'>0
GOTO EXIT
SET PEMP=+Y
DO ST^RMPR29U
+7 SET DIE="^RMPR(664.1,"
SET DR=$SELECT($PIECE($GET(^RMPR(664.1,RMPRDA,7)),U):"19R",1:"19R///^S X=DT")
SET DA=RMPRDA
DO ^DIE
if $DATA(DTOUT)!($DATA(Y))
GOTO EXIT
+8 GOTO DISP^RMPR29D
EXIT ;common exit point
+1 ;CALLED BY RMPR29T
+2 LOCK -^RMPR(664.1,+$GET(RMPRDA),0)
+3 KILL DIC,DIE,DIR,DA,DIRUT,DR,DTOUT,PEMP,PREV,PSM,RMPRDA,RMPRDFN,RMPRWO,RI
+4 KILL PASS,PCOUNT
QUIT
MUL ;MULTIPLE ASSIGN
+1 SET RMPRBAC1=1
+2 KILL PDCA
FOR RI=0:0
SET RI=$ORDER(^RMPR(664.1,"E","P",RI))
if +RI'>0
QUIT
IF +RI
IF $PIECE($GET(^RMPR(664.1,RI,0)),U,3)=RMPR("STA")
SET PDCA(RI)=""
SET PREV(-RI)=""
+3 IF '$DATA(PDCA)
DO MESS
GOTO EXIT
+4 SET PCOUNT=$ORDER(PDCA(PCOUNT))
if $GET(PCOUNT)<1
GOTO EXIT
+5 IF +PCOUNT
SET Y=PCOUNT
SET RMPRDA=Y
SET PSM=1
+6 DO ASM
+7 QUIT
NEXT ;LOOK THRU EXITING 2529-3's
+1 ;CALLED BY RMPR29T
+2 ;VARIABLES REQUIRED: PDCA - AN ARRAY
+3 ; RMPRDA - ENTRY IN FILE 664
+4 ; PCOUNT - AN INDEX
+5 ; RMPR ARRAY - MISCELLANEOUS SET BY
+6 ; A CALL TO DIV4^RMPRSIT
+7 ;I +$O(PDCA(RMPRDA))=0 W $C(7) S Y=RMPRDA G ASM
+8 ;S PCOUNT=$O(PDCA(PCOUNT)) I +PCOUNT S Y=PCOUNT G ASM
+9 ;G ASM
IF +$ORDER(PDCA(RMPRDA))=0
WRITE $CHAR(7),!!,"There are no more 'next' jobs to assign."
HANG 2
QUIT
+10 SET RMPRDA=$ORDER(PDCA(RMPRDA))
IF $GET(RMPRDA)>0
GOTO ASM
+11 QUIT
PREV ;previous record
+1 ;CALLED BY RMPR29T
+2 ;VARIABLE REQUIRED: RMPRDA - SUPSCRIPT IN PREV ARRAY
+3 ; PREV - AN ARRAY
+4 IF +$ORDER(PREV(-RMPRDA))=0
WRITE $CHAR(7)
SET Y=RMPRDA
GOTO ASM
+5 SET Y=$ORDER(PREV(-RMPRDA))
IF $GET(Y)'=""
SET (PCOUNT,Y)=Y*-1
SET PSM=1
SET RMPRDA=Y
GOTO ASM
+6 QUIT
MESS ;message/pause
+1 WRITE !!,$CHAR(7),?5,"No Lab 2529-3's need to be assigned"
HANG 3
+2 QUIT
PRC ;entry point from option RMPR PROCESS 2529-3 JOB
+1 ;PROCESS 2529-3 TO CREATE WORK ORDER
+2 ;CALLED BY RMPR29A
+3 ;VARIABLES REQUIRED: NONE
+4 DO KVAR^VADPT
DO HOME^%ZIS
KILL X,Y,DIC
+5 DO DIV4^RMPRSIT
if $DATA(X)
GOTO EXIT
+6 SET DIC="^RMPR(664.1,"
SET DIC(0)="AEQM"
+7 ;screen
+8 ;if STATION = site selected
+9 ;if WORK ORDER NUMBER not null
+10 ;if NO LAB COUNT null
+11 ;if STATUS "A" Assigned to tech
+12 SET DIC("S")="I $P(^(0),U,3)=RMPR(""STA""),$P(^(0),U,13)'="""",'$P(^(0),U,20),($P(^(0),U,17)=""A"""
+13 SET DIC("W")="D EN3^RMPRD1"
+14 ;change to screen
+15 ;if supervisor key, add to screen
+16 ;if STATUS = "R" returned to tech
+17 ;if STATUS = "PC" pending completion
+18 ;if STATUS = "P" pending assignment
+19 ;or if not supervisor key, add to screen
+20 ;if STATUS = "R"
+21 SET DIC("S")=$SELECT($DATA(^XUSEC("RMPR LAB SUPERVISOR",DUZ)):DIC("S")_"!($P(^(0),U,17)=""R"")!($P(^(0),U,17)=""PC"")!($P(^(0),U,17)=""P""))",1:DIC("S")_"!($P(^(0),U,17)=""R""))")
+22 DO ^DIC
if +Y
SET RMPRDA=+Y
KILL DIC
if +Y'>0
GOTO EXIT
+23 ;
+24 LOCK +^RMPR(664.1,+Y,0):1
IF '$TEST
WRITE !!,?5,$CHAR(7),"Someone is already editing this entry"
GOTO EXIT
+25 SET RMPRDFN=$PIECE(^RMPR(664.1,+Y,0),U,2)
IF '$PIECE(^(0),U,16)
SET RMPRWO=$PIECE(^(0),U,13)
+26 ;preserve value of $T
Begin DoDot:1
+27 ; set patient vars. required for display later on
DO DPTVARS(RMPRDFN)
+28 QUIT
End DoDot:1
+29 IF $TEST
SET DIR(0)="Y"
SET DIR("A")="You are self Assigning WORK ORDER #: "_RMPRWO_" "
SET DIR("B")="YES"
+30 ;if TECHNICIAN null
+31 IF $TEST
WRITE !!
DO ^DIR
if $DATA(DIRUT)!($DATA(DTOUT))!(+Y=0)
GOTO EXIT
IF +Y=1
DO EN4^RMPR29U(RMPRDA)
SET PEMP=DUZ
SET DIE="^RMPR(664.1,"
SET DA=RMPRDA
SET DR="19///^S X=DT"
DO ^DIE
DO ST^RMPR29U
GOTO DISP^RMPR29D
+32 DO EN4^RMPR29U(RMPRDA)
GOTO DISP^RMPR29D
+33 ;exit from RMPR29D
+34 ;
+35 ; Get patient vars using same code as in RMPRUTIL
DPTVARS(DFN) ;
+1 NEW VADM,VAEL
+2 DO DEM^VADPT
+3 DO ELIG^VADPT
+4 ;set prosthetic variables
+5 ;rmprssn is number nnnnnnnnn
+6 ;rmprssne is external format of ssn nnn-nn-nnnn
+7 SET RMPRNAM=$PIECE(VADM(1),U)
SET RMPRSSN=$PIECE(VADM(2),U)
+8 SET RMPRDOB=$PIECE(VADM(3),U)
SET RMPRSSNE=VA("PID")
+9 SET RMPRCNUM=VAEL(7)
+10 QUIT
