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

RMPRPIY2.m

Go to the documentation of this file. 
  1. RMPRPIY2 ;HINCIO/ODJ - PIP Data Entry - Location Prompt ;3/8/01
  1.  ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1.  Q
  1.  ;
  1.  ;***** LOCNM - Prompt for PIP Location by name (used by AE option)
  1.  ;              Use only where location can be added
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPRSTN - Station number
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPREXC - exit condition
  1.  ;    RMPR5   - Array of Location data fields
  1.  ;    RMPRERR - returned error code (ignore for time being)
  1.  ;
  1. LOCNM(RMPRSTN,RMPR5,RMPREXC) ;
  1.  N RMPRERR,DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,RMPRYN,RMPRTDT
  1.  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.  I $G(RMPR5("NAME"))'="" S DIR("B")=RMPR5("NAME")
  1.  S DIR("?")="^D QM^RMPRPIY2"
  1.  S DIR("??")="^D QQM^RMPRPIY2"
  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.  D LIKE(RMPRSTN,X,.RMPREXC,.RMPR5)
  1.  I RMPREXC'="" G LOCNM1
  1.  I +$G(RMPR5("IEN")) G LOCNMX
  1.  I $L(X)<3 D  G LOCNM1
  1.  . W !,"Location name must be at least 3 characters long"
  1.  . Q
  1.  S RMPR5("STATION")=RMPRSTN
  1.  S RMPR5("STATION IEN")=RMPRSTN
  1.  S RMPR5("NAME")=X
  1.  ;
  1.  ; Add new Stock Location
  1. LOCNMA D ADDNM(.RMPR5,.RMPRYN,.RMPREXC)
  1.  I RMPREXC'="" G LOCNM1
  1.  I RMPRYN="N" G LOCNM1
  1.  D ADDR(.RMPR5,.RMPREXC) ; get address for new location
  1.  I RMPREXC'="" G LOCNM1
  1.  S RMPR5("STATUS")="A"
  1.  S RMPR5("STATUS DATE")=RMPRTDT
  1.  S RMPR5("USER")=$G(DUZ)
  1.  S RMPRERR=$$CRE^RMPRPIX5(.RMPR5) ; create new location
  1. LOCNMX Q RMPRERR
  1.  ;
  1.  ;***** ADDNM - Prompts for adding a new Stock Location
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPR5
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPRYN
  1.  ;    RMPREXC
  1.  ;    RMPRERR
  1.  ;
  1. ADDNM(RMPR5,RMPRYN,RMPREXC) ;
  1.  N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DA
  1.  S RMPREXC=""
  1.  S DIR(0)="Y"
  1.  S DIR("B")="N"
  1.  S DIR("A")="Are you adding '"_RMPR5("NAME")_"' as a new PROS ITEM LOCATION"
  1.  D ^DIR
  1.  I $D(DTOUT) S RMPREXC="T" G ADDNMX
  1.  I $D(DIROUT) S RMPREXC="P" G ADDNMX
  1.  I X=""!(X["^") S RMPREXC="^" G ADDNMX
  1.  S RMPRYN="N" S:Y RMPRYN="Y"
  1.  S RMPREXC=""
  1. ADDNMX Q
  1.  ;
  1.  ;***** ADDR - Prompt for Stock Location Address
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPR5
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPR5
  1.  ;    RMPREXC
  1.  ;
  1. ADDR(RMPR5,RMPREXC) ;
  1.  N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT
  1.  S RMPREXC=""
  1.  S DIR(0)="FOA"
  1.  S DIR("A")="   PROS ITEM LOCATION ADDRESS: "
  1.  S DIR("?")="Answer must be 3-30 characters in length."
  1.  D ^DIR
  1.  I $D(DTOUT) S RMPREXC="T" G ADDRX
  1.  I $D(DIROUT) S RMPREXC="P" G ADDRX
  1.  I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G ADDRX
  1.  S RMPR5("ADDRESS")=X
  1. ADDRX Q
  1.  ;
  1.  ;***** QM - Single ? Help (for use by Location prompt)
  1. QM D QM1 ;ask if want to list locns.
  1.  I RMPREXC'="" G QMX
  1.  I RMPRYN'="Y" G QMX
  1.  D QM2 ;list locns.
  1.  D QM2H
  1. QMX Q
  1.  ;
  1.  ; Double ? Help
  1. QQM D QM2 ;list locns.
  1.  D QQM1
  1.  Q
  1.  ;
  1.  ; QM1 - ask if want to list locns
  1.  ;
  1.  ; require RMPRSTN - Station number
  1.  ;
  1.  ; sets RMPREXC - exit condition
  1.  ;      RMPRYN  - Y - list, any other response - don't bother
  1.  ;
  1. QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,%A
  1.  S RMPRYN="N"
  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^RMPRPIY2"
  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:Y RMPRYN="Y"
  1.  S RMPREXC=""
  1. QM1X I RMPRYN'="Y",RMPRYN'="?" D QM1H
  1.  Q
  1. QM1H W:$X'=0 !
  1.  W "        You may enter a new PROS ITEM LOCATION, if you wish"
  1.  W !,"        Answer must be 3-30 characters in length."
  1.  S %A="V",X="^",RMPRYN="?"
  1.  Q
  1. QM2H W !,"        You may enter a new PROS ITEM LOCATION, if you wish"
  1.  W !,"        Answer must be 3-30 characters in length."
  1.  Q
  1. QQM1 W !,"        You may enter a new PROS ITEM LOCATION, if you wish"
  1.  W !,"        This is a location of an item or stock being tracked for inventory."
  1.  Q
  1.  ;
  1.  ;***** QM2 - List Location names; part of help for Location prompt
  1.  ;
  1.  ; require RMPRSTN - Station number
  1.  ;
  1. QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRGBL,RMPRLIN
  1.  S RMPRMAX=19,RMPRLIN=0
  1.  S RMPREXC=""
  1.  S DIR(0)="EA"
  1.  S DIR("A")="'^' TO STOP: "
  1.  W !?3,"Choose from:"
  1.  S RMPRGBL="^RMPR(661.5,"_"""XSL"","_RMPRSTN_")"
  1. QM2A S RMPRGBL=$Q(@RMPRGBL)
  1.  I RMPRGBL="" G QM2X
  1.  I $QS(RMPRGBL,1)'=661.5 G QM2X
  1.  I $QS(RMPRGBL,2)'="XSL" G QM2X
  1.  I $QS(RMPRGBL,3)'=RMPRSTN G QM2X
  1.  W !?3,$QS(RMPRGBL,4)
  1.  S RMPRLIN=RMPRLIN+1
  1.  I RMPRLIN'<RMPRMAX G QM2B
  1.  G QM2A
  1. QM2B D ^DIR
  1.  I $D(DTOUT) S RMPREXC="T" G QM2X
  1.  I $D(DIROUT) S RMPREXC="P" G QM2X
  1.  I (X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
  1.  S RMPRLIN=0
  1.  G QM2A
  1. QM2X W ! Q
  1.  ;
  1.  ;***** LIKE - List Locn names with matching chars.
  1.  ;
  1.  ; Inputs:
  1.  ;    RMPRSTN - Station number
  1.  ;    RMPRTXT - Text to be compared
  1.  ;
  1.  ; Outputs:
  1.  ;    RMPREXC - exit condition
  1.  ;    RMPR5   - array for Location data fields
  1.  ;
  1. LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR5) ;
  1.  N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
  1.  N RMPRI,RMPRERR,RMPRYN,RMPRJ
  1.  S RMPREXC=""
  1.  S RMPRMAX=5
  1.  S RMPRJ=RMPRTXT
  1.  I '$D(^RMPR(661.5,"XSL",RMPRSTN,RMPRJ)) D
  1.  . S RMPRJ=$O(^RMPR(661.5,"XSL",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,"XSL",RMPRSTN,RMPRJ))
  1.  I RMPRI=""!($E(RMPRI,1,$L(RMPRTXT))'=RMPRTXT) D
  1.  . S RMPR5("IEN")=$O(^RMPR(661.5,"XSL",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.  S RMPRGBL="^RMPR(661.5,"_"""XSL"","_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)'="XSL" G LIKEB
  1.  I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
  1.  I $E($QS(RMPRGBL,4),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,4)
  1.  S RMPRA(RMPRLIN)=$QS(RMPRGBL,5)
  1.  G LIKEA
  1. LIKEB I RMPRLIN=0 G LIKEX
  1.  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. LIKEX Q