Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RMPRPIYB

RMPRPIYB.m

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