- 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 Jan 18, 2025@03:38:08 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