RMPRPIY2 ;HINCIO/ODJ - PIP Data Entry - Location Prompt ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** LOCNM - Prompt for PIP Location by name (used by AE option)
; Use only where location can be added
;
; Inputs:
; RMPRSTN - Station number
;
; Outputs:
; RMPREXC - exit condition
; RMPR5 - Array of Location data fields
; RMPRERR - returned error code (ignore for time being)
;
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
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: "
I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME")
S DIR("?")="^D QM^RMPRPIY2"
S DIR("??")="^D QQM^RMPRPIY2"
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
D LIKE(RMPRSTN,X,.RMPREXC,.RMPR5)
I RMPREXC'="" G LOCNM1
I +$G(RMPR5("IEN")) G LOCNMX
I $L(X)<3 D G LOCNM1
. W !,"Location name must be at least 3 characters long"
. Q
S RMPR5("STATION")=RMPRSTN
S RMPR5("STATION IEN")=RMPRSTN
S RMPR5("NAME")=X
;
; Add new Stock Location
LOCNMA D ADDNM(.RMPR5,.RMPRYN,.RMPREXC)
I RMPREXC'="" G LOCNM1
I RMPRYN="N" G LOCNM1
D ADDR(.RMPR5,.RMPREXC) ; get address for new location
I RMPREXC'="" G LOCNM1
S RMPR5("STATUS")="A"
S RMPR5("STATUS DATE")=RMPRTDT
S RMPR5("USER")=$G(DUZ)
S RMPRERR=$$CRE^RMPRPIX5(.RMPR5) ; create new location
LOCNMX Q RMPRERR
;
;***** ADDNM - Prompts for adding a new Stock Location
;
; Inputs:
; RMPR5
;
; Outputs:
; RMPRYN
; RMPREXC
; RMPRERR
;
ADDNM(RMPR5,RMPRYN,RMPREXC) ;
N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
S RMPREXC=""
S DIR(0)="Y"
S DIR("B")="N"
S DIR("A")="Are you adding '"_RMPR5("NAME")_"' as a new PROS ITEM LOCATION"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G ADDNMX
I $D(DIROUT) S RMPREXC="P" G ADDNMX
I X=""!(X["^") S RMPREXC="^" G ADDNMX
S RMPRYN="N" S:Y RMPRYN="Y"
S RMPREXC=""
ADDNMX Q
;
;***** ADDR - Prompt for Stock Location Address
;
; Inputs:
; RMPR5
;
; Outputs:
; RMPR5
; RMPREXC
;
ADDR(RMPR5,RMPREXC) ;
N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT
S RMPREXC=""
S DIR(0)="FOA"
S DIR("A")=" PROS ITEM LOCATION ADDRESS: "
S DIR("?")="Answer must be 3-30 characters in length."
D ^DIR
I $D(DTOUT) S RMPREXC="T" G ADDRX
I $D(DIROUT) S RMPREXC="P" G ADDRX
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ADDRX
S RMPR5("ADDRESS")=X
ADDRX Q
;
;***** QM - Single ? Help (for use by Location prompt)
QM D QM1 ;ask if want to list locns.
I RMPREXC'="" G QMX
I RMPRYN'="Y" G QMX
D QM2 ;list locns.
D QM2H
QMX Q
;
; Double ? Help
QQM D QM2 ;list locns.
D QQM1
Q
;
; QM1 - ask if want to list locns
;
; require RMPRSTN - Station number
;
; sets RMPREXC - exit condition
; RMPRYN - Y - list, any other response - don't bother
;
QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,%A
S RMPRYN="N"
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^RMPRPIY2"
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:Y RMPRYN="Y"
S RMPREXC=""
QM1X I RMPRYN'="Y",RMPRYN'="?" D QM1H
Q
QM1H W:$X'=0 !
W " You may enter a new PROS ITEM LOCATION, if you wish"
W !," Answer must be 3-30 characters in length."
S %A="V",X="^",RMPRYN="?"
Q
QM2H W !," You may enter a new PROS ITEM LOCATION, if you wish"
W !," Answer must be 3-30 characters in length."
Q
QQM1 W !," You may enter a new PROS ITEM LOCATION, if you wish"
W !," This is a location of an item or stock being tracked for inventory."
Q
;
;***** QM2 - List Location names; part of help for Location prompt
;
; require RMPRSTN - Station number
;
QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRGBL,RMPRLIN
S RMPRMAX=19,RMPRLIN=0
S RMPREXC=""
S DIR(0)="EA"
S DIR("A")="'^' TO STOP: "
W !?3,"Choose from:"
S RMPRGBL="^RMPR(661.5,"_"""XSL"","_RMPRSTN_")"
QM2A S RMPRGBL=$Q(@RMPRGBL)
I RMPRGBL="" G QM2X
I $QS(RMPRGBL,1)'=661.5 G QM2X
I $QS(RMPRGBL,2)'="XSL" G QM2X
I $QS(RMPRGBL,3)'=RMPRSTN G QM2X
W !?3,$QS(RMPRGBL,4)
S RMPRLIN=RMPRLIN+1
I RMPRLIN'<RMPRMAX G QM2B
G QM2A
QM2B D ^DIR
I $D(DTOUT) S RMPREXC="T" G QM2X
I $D(DIROUT) S RMPREXC="P" G QM2X
I (X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
S RMPRLIN=0
G QM2A
QM2X W ! Q
;
;***** LIKE - List Locn names with matching chars.
;
; Inputs:
; RMPRSTN - Station number
; RMPRTXT - Text to be compared
;
; Outputs:
; RMPREXC - exit condition
; RMPR5 - array for Location data fields
;
LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR5) ;
N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
N RMPRI,RMPRERR,RMPRYN,RMPRJ
S RMPREXC=""
S RMPRMAX=5
S RMPRJ=RMPRTXT
I '$D(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ)) D
. S RMPRJ=$O(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
. Q
I RMPRJ=""!($E(RMPRJ,1,$L(RMPRTXT))'=RMPRTXT) S RMPR5("IEN")="" G LIKEX
S RMPRI=$O(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
I RMPRI=""!($E(RMPRI,1,$L(RMPRTXT))'=RMPRTXT) D
. S RMPR5("IEN")=$O(^RMPR(661.5,"XSL",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
S RMPRGBL="^RMPR(661.5,"_"""XSL"","_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)'="XSL" G LIKEB
I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
I $E($QS(RMPRGBL,4),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,4)
S RMPRA(RMPRLIN)=$QS(RMPRGBL,5)
G LIKEA
LIKEB I RMPRLIN=0 G LIKEX
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")
LIKEX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIY2 6528 printed Sep 23, 2025@20:13 Page 2
RMPRPIY2 ;HINCIO/ODJ - PIP Data Entry - Location Prompt ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** LOCNM - Prompt for PIP Location by name (used by AE option)
+5 ; Use only where location can be added
+6 ;
+7 ; Inputs:
+8 ; RMPRSTN - Station number
+9 ;
+10 ; Outputs:
+11 ; RMPREXC - exit condition
+12 ; RMPR5 - Array of Location data fields
+13 ; RMPRERR - returned error code (ignore for time being)
+14 ;
LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
+2 ;today's date
DO NOW^%DTC
SET RMPRTDT=X
+3 SET RMPREXC=""
+4 SET RMPRERR=0
+5 SET DIR(0)="FOA^1:30"
+6 SET DIR("A")="Enter Pros Location: "
+7 IF $GET(RMPR5("NAME"))'=""
SET DIR("B")=RMPR5("NAME")
+8 SET DIR("?")="^D QM^RMPRPIY2"
+9 SET DIR("??")="^D QQM^RMPRPIY2"
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 DO LIKE(RMPRSTN,X,.RMPREXC,.RMPR5)
+6 IF RMPREXC'=""
GOTO LOCNM1
+7 IF +$GET(RMPR5("IEN"))
GOTO LOCNMX
+8 IF $LENGTH(X)<3
Begin DoDot:1
+9 WRITE !,"Location name must be at least 3 characters long"
+10 QUIT
End DoDot:1
GOTO LOCNM1
+11 SET RMPR5("STATION")=RMPRSTN
+12 SET RMPR5("STATION IEN")=RMPRSTN
+13 SET RMPR5("NAME")=X
+14 ;
+15 ; Add new Stock Location
LOCNMA DO ADDNM(.RMPR5,.RMPRYN,.RMPREXC)
+1 IF RMPREXC'=""
GOTO LOCNM1
+2 IF RMPRYN="N"
GOTO LOCNM1
+3 ; get address for new location
DO ADDR(.RMPR5,.RMPREXC)
+4 IF RMPREXC'=""
GOTO LOCNM1
+5 SET RMPR5("STATUS")="A"
+6 SET RMPR5("STATUS DATE")=RMPRTDT
+7 SET RMPR5("USER")=$GET(DUZ)
+8 ; create new location
SET RMPRERR=$$CRE^RMPRPIX5(.RMPR5)
LOCNMX QUIT RMPRERR
+1 ;
+2 ;***** ADDNM - Prompts for adding a new Stock Location
+3 ;
+4 ; Inputs:
+5 ; RMPR5
+6 ;
+7 ; Outputs:
+8 ; RMPRYN
+9 ; RMPREXC
+10 ; RMPRERR
+11 ;
ADDNM(RMPR5,RMPRYN,RMPREXC) ;
+1 NEW DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
+2 SET RMPREXC=""
+3 SET DIR(0)="Y"
+4 SET DIR("B")="N"
+5 SET DIR("A")="Are you adding '"_RMPR5("NAME")_"' as a new PROS ITEM LOCATION"
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ADDNMX
+8 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ADDNMX
+9 IF X=""!(X["^")
SET RMPREXC="^"
GOTO ADDNMX
+10 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
+11 SET RMPREXC=""
ADDNMX QUIT
+1 ;
+2 ;***** ADDR - Prompt for Stock Location Address
+3 ;
+4 ; Inputs:
+5 ; RMPR5
+6 ;
+7 ; Outputs:
+8 ; RMPR5
+9 ; RMPREXC
+10 ;
ADDR(RMPR5,RMPREXC) ;
+1 NEW DIR,X,Y,DA,DUOUT,DTOUT,DIROUT
+2 SET RMPREXC=""
+3 SET DIR(0)="FOA"
+4 SET DIR("A")=" PROS ITEM LOCATION ADDRESS: "
+5 SET DIR("?")="Answer must be 3-30 characters in length."
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ADDRX
+8 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ADDRX
+9 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO ADDRX
+10 SET RMPR5("ADDRESS")=X
ADDRX QUIT
+1 ;
+2 ;***** QM - Single ? Help (for use by Location prompt)
QM ;ask if want to list locns.
DO QM1
+1 IF RMPREXC'=""
GOTO QMX
+2 IF RMPRYN'="Y"
GOTO QMX
+3 ;list locns.
DO QM2
+4 DO QM2H
QMX QUIT
+1 ;
+2 ; Double ? Help
QQM ;list locns.
DO QM2
+1 DO QQM1
+2 QUIT
+3 ;
+4 ; QM1 - ask if want to list locns
+5 ;
+6 ; require RMPRSTN - Station number
+7 ;
+8 ; sets RMPREXC - exit condition
+9 ; RMPRYN - Y - list, any other response - don't bother
+10 ;
QM1 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,%A
+1 SET RMPRYN="N"
+2 SET DIR("A",1)=" Answer with PROS ITEM LOCATION"
+3 SET DIR("A")=" Do you want the entire PROS ITEM LOCATION List"
+4 SET DIR("?")="^D QM1H^RMPRPIY2"
+5 SET DIR(0)="YO"
+6 DO ^DIR
+7 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QM1X
+8 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QM1X
+9 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO QM1X
+10 if Y
SET RMPRYN="Y"
+11 SET RMPREXC=""
QM1X IF RMPRYN'="Y"
IF RMPRYN'="?"
DO QM1H
+1 QUIT
QM1H if $X'=0
WRITE !
+1 WRITE " You may enter a new PROS ITEM LOCATION, if you wish"
+2 WRITE !," Answer must be 3-30 characters in length."
+3 SET %A="V"
SET X="^"
SET RMPRYN="?"
+4 QUIT
QM2H WRITE !," You may enter a new PROS ITEM LOCATION, if you wish"
+1 WRITE !," Answer must be 3-30 characters in length."
+2 QUIT
QQM1 WRITE !," You may enter a new PROS ITEM LOCATION, if you wish"
+1 WRITE !," This is a location of an item or stock being tracked for inventory."
+2 QUIT
+3 ;
+4 ;***** QM2 - List Location names; part of help for Location prompt
+5 ;
+6 ; require RMPRSTN - Station number
+7 ;
QM2 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRGBL,RMPRLIN
+1 SET RMPRMAX=19
SET RMPRLIN=0
+2 SET RMPREXC=""
+3 SET DIR(0)="EA"
+4 SET DIR("A")="'^' TO STOP: "
+5 WRITE !?3,"Choose from:"
+6 SET RMPRGBL="^RMPR(661.5,"_"""XSL"","_RMPRSTN_")"
QM2A SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF RMPRGBL=""
GOTO QM2X
+2 IF $QSUBSCRIPT(RMPRGBL,1)'=661.5
GOTO QM2X
+3 IF $QSUBSCRIPT(RMPRGBL,2)'="XSL"
GOTO QM2X
+4 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
GOTO QM2X
+5 WRITE !?3,$QSUBSCRIPT(RMPRGBL,4)
+6 SET RMPRLIN=RMPRLIN+1
+7 IF RMPRLIN'<RMPRMAX
GOTO QM2B
+8 GOTO QM2A
QM2B DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QM2X
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QM2X
+3 IF (X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO QM2X
+4 SET RMPRLIN=0
+5 GOTO QM2A
QM2X WRITE !
QUIT
+1 ;
+2 ;***** LIKE - List Locn names with matching chars.
+3 ;
+4 ; Inputs:
+5 ; RMPRSTN - Station number
+6 ; RMPRTXT - Text to be compared
+7 ;
+8 ; Outputs:
+9 ; RMPREXC - exit condition
+10 ; RMPR5 - array for Location data fields
+11 ;
LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR5) ;
+1 NEW RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
+2 NEW RMPRI,RMPRERR,RMPRYN,RMPRJ
+3 SET RMPREXC=""
+4 SET RMPRMAX=5
+5 SET RMPRJ=RMPRTXT
+6 IF '$DATA(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
Begin DoDot:1
+7 SET RMPRJ=$ORDER(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
+8 QUIT
End DoDot:1
+9 IF RMPRJ=""!($EXTRACT(RMPRJ,1,$LENGTH(RMPRTXT))'=RMPRTXT)
SET RMPR5("IEN")=""
GOTO LIKEX
+10 SET RMPRI=$ORDER(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ))
+11 IF RMPRI=""!($EXTRACT(RMPRI,1,$LENGTH(RMPRTXT))'=RMPRTXT)
Begin DoDot:1
+12 SET RMPR5("IEN")=$ORDER(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ,""))
+13 if RMPRJ'=RMPRTXT
WRITE $EXTRACT(RMPRJ,1+$LENGTH(RMPRTXT),$LENGTH(RMPRJ))
+14 SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
+15 DO OK^RMPRPIYB(.RMPRYN,)
+16 QUIT
End DoDot:1
+17 IF $GET(RMPR5("IEN"))'=""
if RMPRYN'="Y"
SET RMPR5("IEN")=""
SET RMPREXC="^"
GOTO LIKEX
+18 SET RMPRGBL="^RMPR(661.5,"_"""XSL"","_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)'="XSL"
GOTO LIKEB
+3 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
GOTO LIKEB
+4 IF $EXTRACT($QSUBSCRIPT(RMPRGBL,4),1,$LENGTH(RMPRTXT))'=RMPRTXT
GOTO LIKEB
+5 IF RMPRLIN
IF '(RMPRLIN#RMPRMAX)
Begin DoDot:1
+6 SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, OR"
+7 QUIT
End DoDot:1
GOTO LIKEB
LIKEA3 SET RMPRLIN=RMPRLIN+1
+1 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,$QSUBSCRIPT(RMPRGBL,4)
+2 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,5)
+3 GOTO LIKEA
LIKEB IF RMPRLIN=0
GOTO LIKEX
+1 SET DIR(0)="NAO^1:"_RMPRLIN_":0"
+2 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+3 DO ^DIR
+4 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LIKEX
+5 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LIKEX
+6 IF X=""
IF $DATA(DIR("A",1))
KILL DIR("A",1)
GOTO LIKEA3
+7 IF X=""
SET RMPREXC="^"
GOTO LIKEX
+8 IF X["^"!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+9 KILL RMPR5
+10 SET RMPR5("IEN")=RMPRA(X)
+11 SET RMPRERR=$$GET^RMPRPIX5(.RMPR5)
+12 WRITE " ",RMPR5("NAME")
LIKEX QUIT
