RMPRPIYB ;HINCIO/ODJ - PIP Prompts - Select Existing Location ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** LOCNM - General Prompt for stock location.
; Location must exist in ^RMPR(661.5 and be active
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
STA D NOW^%DTC S RMPRTDT=X ;today's date
S RMPREXC=""
S RMPRERR=0
S DIR(0)="FOA^1:30"
S DIR("A")="Enter Pros Location: "
S DIR("?")="^D QM^RMPRPIYB"
S DIR("??")="^D QM2^RMPRPIYB"
W STA
LOCNM1 D ^DIR
I $D(DTOUT) S RMPREXC="T" G LOCNMX
I $D(DIROUT) S RMPREXC="P" G LOCNMX
I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G LOCNMX
K RMPR5
S RMPR5("STATION")=RMPRSTN
S RMPR5("NAME")=X
D LIKE(RMPRSTN,X,.RMPREXC,.RMPR5)
I $G(RMPR5("IEN"))="" D G LOCNM1
. W !,"Please enter a valid Location"
. Q
G LOCNMX
;
; exit
LOCNMX Q RMPRERR
;
; Single ? Help
QM D QM1 ;ask if want to list locns.
I RMPREXC'="" G QMX
I RMPRYN="N" G QMX
D QM2 ;list locns.
I $G(RMPR5("IEN"))'="" D QM1H
QMX Q
;
; QM1 - ask if want to list locns
;
; require RMPRSTN - Station number
;
; returns RMPREXC - exit condition
; RMPRYN - Y - list, N - don't bother
;
QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT
S DIR("A",1)=" Answer with PROS ITEM LOCATION"
S DIR("A")=" Do you want the entire PROS ITEM LOCATION List"
S DIR("?")="^D QM1H^RMPRPIYB"
S DIR(0)="YO"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G QM1X
I $D(DIROUT) S RMPREXC="P" G QM1X
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM1X
S RMPRYN="N" S:Y RMPRYN="Y"
S RMPREXC=""
QM1X Q
QM1H S %A="V",X="^"
Q
;
; QM2 - List active Location names (only to called from DIR("?"))
;
; require RMPRSTN - Station number
;
QM2 D LIKE(RMPRSTN,"",.RMPREXC,.RMPR5)
I $G(RMPR5("IEN"))'="" D QM1H
Q
;
; LIKE - List active Locn. names with matching chars.
LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR5) ;
N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
N RMPRYN,RMPRI,RMPRJ,RMPRERR
S RMPREXC=""
S RMPRYN=""
S RMPRMAX=15
S RMPRJ=RMPRTXT
I RMPRJ="" G LIKEA0
I '$D(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ)) D
. S RMPRJ=$O(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ))
. Q
I RMPRJ=""!($E(RMPRJ,1,$L(RMPRTXT))'=RMPRTXT) S RMPR5("IEN")="" G LIKEX
S RMPRI=$O(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ))
I RMPRI=""!($E(RMPRI,1,$L(RMPRTXT))'=RMPRTXT) D
. S RMPR5("IEN")=$O(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ,""))
. W:RMPRJ'=RMPRTXT $E(RMPRJ,1+$L(RMPRTXT),$L(RMPRJ))
. S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
. D OK^RMPRPIYB(.RMPRYN,)
. Q
I $G(RMPR5("IEN"))'="" S:RMPRYN'="Y" RMPR5("IEN")="",RMPREXC="^" G LIKEX
LIKEA0 S RMPRGBL="^RMPR(661.5,"_"""ASSL"",""A"","_RMPRSTN_","""_RMPRTXT_""")"
LIKEA1 K RMPRA S RMPRLIN=0
LIKEA S RMPRGBL=$Q(@RMPRGBL)
LIKEA2 I RMPRGBL="" G LIKEB
I $QS(RMPRGBL,1)'=661.5 G LIKEB
I $QS(RMPRGBL,2)'="ASSL" G LIKEB
I $QS(RMPRGBL,3)'="A" G LIKEB
I $QS(RMPRGBL,4)'=RMPRSTN G LIKEB
I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
I RMPRLIN,'(RMPRLIN#RMPRMAX) D G LIKEB
. S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, OR"
. Q
LIKEA3 S RMPRLIN=RMPRLIN+1
W !,?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5)
S RMPRA(RMPRLIN)=$QS(RMPRGBL,6)
G LIKEA
LIKEB I RMPRLIN=0 G LIKEX
LIKEC S DIR(0)="NAO^1:"_RMPRLIN_":0"
S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
D ^DIR
I $D(DTOUT) S RMPREXC="T" G LIKEX
I $D(DIROUT) S RMPREXC="P" G LIKEX
I X="",$D(DIR("A",1)) K DIR("A",1) G LIKEA3
I X="" S RMPREXC="^" G LIKEX
I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
K RMPR5
S RMPR5("IEN")=RMPRA(X)
S RMPRERR=$$GET^RMPRPIX5(.RMPR5)
W " "_RMPR5("NAME")
S RMPREXC=""
LIKEX Q
;
;***** OK - prompt for OK
;
; Outputs:
; RMPRYN - Y - yes N - No
; RMPREXC - Exit condition
;
OK(RMPRYN,RMPREXC) ;
N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
S RMPREXC="",RMPRYN="N"
S DIR("A")=" ...OK"
S DIR("B")="Yes"
S DIR(0)="Y"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G OKX
I $D(DIROUT) S RMPREXC="P" G OKX
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G OKX
S:Y RMPRYN="Y"
OKX Q
;
; Function - returns location ien if 1 active location, else 0
LOC1(RMPRSTN) ;
N RMPRL,RMPR1LOC
S RMPR1LOC=0
S RMPRL=$O(^RMPR(661.5,"ASSL","A",RMPRSTN,""))
I RMPRL'="" D
. S RMPR1LOC=$O(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRL,""))
. S RMPRL=$O(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRL))
. Q
S:RMPRL'="" RMPR1LOC=0
Q RMPR1LOC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYB 4437 printed Sep 23, 2025@20:13:09 Page 2
RMPRPIYB ;HINCIO/ODJ - PIP Prompts - Select Existing Location ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** LOCNM - General Prompt for stock location.
+5 ; Location must exist in ^RMPR(661.5 and be active
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
STA ;today's date
DO NOW^%DTC
SET RMPRTDT=X
+1 SET RMPREXC=""
+2 SET RMPRERR=0
+3 SET DIR(0)="FOA^1:30"
+4 SET DIR("A")="Enter Pros Location: "
+5 SET DIR("?")="^D QM^RMPRPIYB"
+6 SET DIR("??")="^D QM2^RMPRPIYB"
+7 WRITE STA
LOCNM1 DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LOCNMX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LOCNMX
+3 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO LOCNMX
+4 KILL RMPR5
+5 SET RMPR5("STATION")=RMPRSTN
+6 SET RMPR5("NAME")=X
+7 DO LIKE(RMPRSTN,X,.RMPREXC,.RMPR5)
+8 IF $GET(RMPR5("IEN"))=""
Begin DoDot:1
+9 WRITE !,"Please enter a valid Location"
+10 QUIT
End DoDot:1
GOTO LOCNM1
+11 GOTO LOCNMX
+12 ;
+13 ; exit
LOCNMX QUIT RMPRERR
+1 ;
+2 ; Single ? Help
QM ;ask if want to list locns.
DO QM1
+1 IF RMPREXC'=""
GOTO QMX
+2 IF RMPRYN="N"
GOTO QMX
+3 ;list locns.
DO QM2
+4 IF $GET(RMPR5("IEN"))'=""
DO QM1H
QMX QUIT
+1 ;
+2 ; QM1 - ask if want to list locns
+3 ;
+4 ; require RMPRSTN - Station number
+5 ;
+6 ; returns RMPREXC - exit condition
+7 ; RMPRYN - Y - list, N - don't bother
+8 ;
QM1 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT
+1 SET DIR("A",1)=" Answer with PROS ITEM LOCATION"
+2 SET DIR("A")=" Do you want the entire PROS ITEM LOCATION List"
+3 SET DIR("?")="^D QM1H^RMPRPIYB"
+4 SET DIR(0)="YO"
+5 DO ^DIR
+6 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QM1X
+7 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QM1X
+8 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO QM1X
+9 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
+10 SET RMPREXC=""
QM1X QUIT
QM1H SET %A="V"
SET X="^"
+1 QUIT
+2 ;
+3 ; QM2 - List active Location names (only to called from DIR("?"))
+4 ;
+5 ; require RMPRSTN - Station number
+6 ;
QM2 DO LIKE(RMPRSTN,"",.RMPREXC,.RMPR5)
+1 IF $GET(RMPR5("IEN"))'=""
DO QM1H
+2 QUIT
+3 ;
+4 ; LIKE - List active Locn. names with matching chars.
LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR5) ;
+1 NEW RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
+2 NEW RMPRYN,RMPRI,RMPRJ,RMPRERR
+3 SET RMPREXC=""
+4 SET RMPRYN=""
+5 SET RMPRMAX=15
+6 SET RMPRJ=RMPRTXT
+7 IF RMPRJ=""
GOTO LIKEA0
+8 IF '$DATA(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ))
Begin DoDot:1
+9 SET RMPRJ=$ORDER(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ))
+10 QUIT
End DoDot:1
+11 IF RMPRJ=""!($EXTRACT(RMPRJ,1,$LENGTH(RMPRTXT))'=RMPRTXT)
SET RMPR5("IEN")=""
GOTO LIKEX
+12 SET RMPRI=$ORDER(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ))
+13 IF RMPRI=""!($EXTRACT(RMPRI,1,$LENGTH(RMPRTXT))'=RMPRTXT)
Begin DoDot:1
+14 SET RMPR5("IEN")=$ORDER(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRJ,""))
+15 if RMPRJ'=RMPRTXT
WRITE $EXTRACT(RMPRJ,1+$LENGTH(RMPRTXT),$LENGTH(RMPRJ))
+16 SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
+17 DO OK^RMPRPIYB(.RMPRYN,)
+18 QUIT
End DoDot:1
+19 IF $GET(RMPR5("IEN"))'=""
if RMPRYN'="Y"
SET RMPR5("IEN")=""
SET RMPREXC="^"
GOTO LIKEX
LIKEA0 SET RMPRGBL="^RMPR(661.5,"_"""ASSL"",""A"","_RMPRSTN_","""_RMPRTXT_""")"
LIKEA1 KILL RMPRA
SET RMPRLIN=0
LIKEA SET RMPRGBL=$QUERY(@RMPRGBL)
LIKEA2 IF RMPRGBL=""
GOTO LIKEB
+1 IF $QSUBSCRIPT(RMPRGBL,1)'=661.5
GOTO LIKEB
+2 IF $QSUBSCRIPT(RMPRGBL,2)'="ASSL"
GOTO LIKEB
+3 IF $QSUBSCRIPT(RMPRGBL,3)'="A"
GOTO LIKEB
+4 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRSTN
GOTO LIKEB
+5 IF $EXTRACT($QSUBSCRIPT(RMPRGBL,5),1,$LENGTH(RMPRTXT))'=RMPRTXT
GOTO LIKEB
+6 IF RMPRLIN
IF '(RMPRLIN#RMPRMAX)
Begin DoDot:1
+7 SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, OR"
+8 QUIT
End DoDot:1
GOTO LIKEB
LIKEA3 SET RMPRLIN=RMPRLIN+1
+1 WRITE !,?4,$JUSTIFY(RMPRLIN,2),?9,$QSUBSCRIPT(RMPRGBL,5)
+2 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,6)
+3 GOTO LIKEA
LIKEB IF RMPRLIN=0
GOTO LIKEX
LIKEC SET DIR(0)="NAO^1:"_RMPRLIN_":0"
+1 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+2 DO ^DIR
+3 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LIKEX
+4 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LIKEX
+5 IF X=""
IF $DATA(DIR("A",1))
KILL DIR("A",1)
GOTO LIKEA3
+6 IF X=""
SET RMPREXC="^"
GOTO LIKEX
+7 IF X["^"!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+8 KILL RMPR5
+9 SET RMPR5("IEN")=RMPRA(X)
+10 SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
+11 WRITE " "_RMPR5("NAME")
+12 SET RMPREXC=""
LIKEX QUIT
+1 ;
+2 ;***** OK - prompt for OK
+3 ;
+4 ; Outputs:
+5 ; RMPRYN - Y - yes N - No
+6 ; RMPREXC - Exit condition
+7 ;
OK(RMPRYN,RMPREXC) ;
+1 NEW DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
+2 SET RMPREXC=""
SET RMPRYN="N"
+3 SET DIR("A")=" ...OK"
+4 SET DIR("B")="Yes"
+5 SET DIR(0)="Y"
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO OKX
+8 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO OKX
+9 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO OKX
+10 if Y
SET RMPRYN="Y"
OKX QUIT
+1 ;
+2 ; Function - returns location ien if 1 active location, else 0
LOC1(RMPRSTN) ;
+1 NEW RMPRL,RMPR1LOC
+2 SET RMPR1LOC=0
+3 SET RMPRL=$ORDER(^RMPR(661.5,"ASSL","A",RMPRSTN,""))
+4 IF RMPRL'=""
Begin DoDot:1
+5 SET RMPR1LOC=$ORDER(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRL,""))
+6 SET RMPRL=$ORDER(^RMPR(661.5,"ASSL","A",RMPRSTN,RMPRL))
+7 QUIT
End DoDot:1
+8 if RMPRL'=""
SET RMPR1LOC=0
+9 QUIT RMPR1LOC
