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

RMPRPIY8.m

Go to the documentation of this file.
  1. RMPRPIY8 ;HINCIO/ODJ - Pick HCPCS Item ;3/8/01
  1. ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1. Q
  1. ;
  1. ; ? Help
  1. QM W ?4,"Answer with ITEM, or NUMBER, or DESCRIPTION"
  1. W !?3,"Choose from:"
  1. D QM2
  1. Q
  1. ;
  1. ; ?? Help
  1. QQM W !?3,"Choose from:"
  1. D QM2
  1. Q
  1. QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
  1. S RMPRMAX=5,RMPRLIN=0
  1. S RMPREXC=""
  1. S DIR(0)="EA"
  1. S DIR("A")="'^' TO STOP: "
  1. S RMPRI=""
  1. QM2A S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
  1. I RMPRI="" G QM2X
  1. K RMPR
  1. S RMPR("STATION")=RMPRSTN
  1. S RMPR("HCPCS")=RMPRHCPC
  1. S RMPR("ITEM")=RMPRI
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR)
  1. S RMPRLIN=RMPRLIN+1
  1. W !?3,RMPRLIN,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
  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=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
  1. QM2X Q
  1. ;
  1. ;
  1. LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11,RMPR4) ;
  1. N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
  1. N RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA,RMPRI,RMPRIEN,RMPRH
  1. S RMPREXC=""
  1. S RMPRMAX=5
  1. S RMPR4("IEN")=""
  1. ;
  1. ; NUMBER entered
  1. ; loop on index until count=entered number
  1. I RMPRTXT?1.N D G LIKEX
  1. . S RMPRLIN=0
  1. . S RMPRI=""
  1. . F S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI)) Q:RMPRI="" D Q:RMPR4("IEN")'=""
  1. .. S RMPRLIN=RMPRLIN+1
  1. .. I RMPRLIN=RMPRTXT D
  1. ... S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI,""))
  1. ... S RMPR4("IEN")=RMPRIEN
  1. ... K RMPR11
  1. ... S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
  1. ... S RMPR11("STATION")=RMPRSTN
  1. ... S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. ... Q
  1. .. Q
  1. . Q
  1. ;
  1. ; ITEM entered (HCPCS-ITEM form eg. L5000-3)
  1. S RMPRH=$P(RMPRTXT,"-",1)
  1. I $E(RMPRHCPC,1,$L(RMPRH))=RMPRH G LIKEH1 ;use 661.4 index
  1. ;
  1. ; DESCRIPTION entered - use 661.11 index
  1. S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
  1. LIKEA1 K RMPRA S RMPRLIN=0
  1. LIKEA S RMPRGBL=$Q(@RMPRGBL)
  1. I RMPRGBL="" G LIKEB
  1. I $QS(RMPRGBL,1)'=661.11 G LIKEB
  1. I $QS(RMPRGBL,2)'="ASHD" G LIKEB
  1. I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
  1. I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
  1. I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
  1. K RMPR
  1. S RMPR("IEN")=$QS(RMPRGBL,6)
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR) ;read 661.11 file
  1. I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"))) G LIKEA ;item not in selected location
  1. S RMPRLIN=RMPRLIN+1
  1. W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5),?40,RMPR("HCPCS-ITEM")
  1. S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"),""))
  1. S RMPRA(RMPRLIN)=RMPRIEN
  1. I RMPRLIN'<RMPRMAX G LIKEB
  1. G LIKEA
  1. LIKEB I RMPRLIN=0 G LIKEX
  1. S DIR(0)="NAO^1:"_RMPRLIN_": "
  1. S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
  1. D ^DIR
  1. W !
  1. I $D(DTOUT) S RMPREXC="T" G LIKEX
  1. I $D(DIROUT) S RMPREXC="P" G LIKEX
  1. I X="" S RMPREXC="" G LIKEA
  1. I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
  1. K RMPR11
  1. S RMPR4("IEN")=RMPRA(X)
  1. S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
  1. S RMPR11("STATION")=RMPRSTN
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. G LIKEX
  1. ;
  1. ;
  1. LIKEH1 S RMPRI=$P(RMPRTXT,"-",2)
  1. I RMPRI'="",$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI)) D G LIKEH9A
  1. . S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI,""))
  1. . Q
  1. S RMPRGBL="^RMPR(661.4,"_"""ASLHI"","_RMPRSTN_","_RMPRLCN_","""_RMPRH_""")"
  1. K RMPRA S RMPRLIN=0
  1. LIKEH S RMPRGBL=$Q(@RMPRGBL)
  1. I RMPRGBL="" G LIKEH9
  1. I $QS(RMPRGBL,1)'=661.4 G LIKEH9
  1. I $QS(RMPRGBL,2)'="ASLHI" G LIKEH9
  1. I $QS(RMPRGBL,3)'=RMPRSTN G LIKEH9
  1. I $QS(RMPRGBL,4)'=RMPRLCN G LIKEH9
  1. I $QS(RMPRGBL,5)'=RMPRHCPC G LIKEH
  1. S RMPR("IEN")=$QS(RMPRGBL,7)
  1. K RMPR11
  1. S RMPRERR=$$GET^RMPRPIX4(.RMPR,.RMPR11,)
  1. S RMPR11("STATION")=RMPRSTN
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. S RMPRLIN=RMPRLIN+1
  1. W !?4,$J(RMPRLIN,2),?9,RMPR11("HCPCS-ITEM"),?23,RMPR11("DESCRIPTION")
  1. S RMPRA(RMPRLIN)=$QS(RMPRGBL,7)
  1. I RMPRLIN'<RMPRMAX G LIKEH9
  1. G LIKEH
  1. LIKEH9 I RMPRLIN=0 G LIKEX
  1. S DIR(0)="NAO^1:"_RMPRLIN_": "
  1. S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
  1. D ^DIR
  1. W !
  1. I $D(DTOUT) S RMPREXC="T" G LIKEX
  1. I $D(DIROUT) S RMPREXC="P" G LIKEX
  1. I X="" S RMPREXC="" G LIKEH
  1. I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
  1. S RMPR4("IEN")=RMPRA(X)
  1. LIKEH9A K RMPR11
  1. S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
  1. S RMPR11("STATION")=RMPRSTN
  1. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. G LIKEX
  1. ;exit
  1. LIKEX Q