RMPRPIYC ;HINCIO/ODJ - PIP HCPCS Prompt utilities ;3/8/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
Q
;
;***** HCPCS - Prompt for HCPCS called by reconciliation option
; (RMPRPIYA)
HCPCS(RMPR5,RMPR1,RMPR11,RMPREXC) ;
N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N
N RMPRYN
S DIR("A")="Select HCPCS to RECONCILE: "
S RMPRERR=0
S RMPREXC=""
S RMPR1("HCPCS")=$G(RMPR1("HCPCS"))
S RMPRSTN=RMPR5("STATION")
S RMPRLCN=RMPR5("IEN")
S DIR(0)="FOA"
S DIR("?")="^D QM^RMPRPIYC"
S DIR("??")="^D QM2^RMPRPIYC"
HCPCS1 K RMPR1N D ^DIR
I $D(DTOUT) S RMPREXC="T" G HCPCSX
I $D(DIROUT) S RMPREXC="P" G HCPCSX
I X=""!(X["^")!($D(DUOUT)) S RMPREXC="^" G HCPCSX
D LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11)
I RMPREXC'="" G HCPCS1
I $G(RMPR1N("IEN"))'="" G HCPCSU
G HCPCS1
HCPCSU K RMPR1 M RMPR1=RMPR1N
HCPCSX Q RMPRERR
;
;***** QM - Single ? Help
; RMPRSTN required (see below QM2)
;
QM D QM1 ; ask if want to list HCPCS
I RMPREXC'="" G QMX
I RMPRYN="N" G QMX
D QM2 ;list HCPCS
QMX Q
QM1 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT
;S DIR("A",1)=" Answer with PSAS HCPCS, or SHORT NAME, or CPT, or SYNONYM, or"
;S DIR("A",2)=" DESCRIPTION"
S DIR("A",1)="This response must be a number."
S DIR("A")="Do you want the entire list of PSAS HCPCS in inventory "
S DIR("?")="^D QM1H^RMPRPIYC"
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 HCPCS associated with a Location
; called from a ?? help or Yes to the
; question in the ? help.
;
; requires RMPRSTN - Station ien
;
QM2 D LIKE(RMPRSTN,"",.RMPREXC,.RMPR1N,.RMPR11)
I $G(RMPR1N("IEN"))'="" D QM1H
QM2X Q
;
; ***** LIKE
; Handle the various inputs from a HCPCS prompt where HCPCS is
; being selected from PIP as opposed to the general
; HCPCS file 661.1
; This version uses the 661.11 file so any HCPCS that has been
; used in inventory can be selected.
;
; Inputs:
; RMPRSTN - Station ien
; RMPRTXT - Text entered at HCPCS prompt (cannot be null)
;
; Outputs:
; RMPREXC - exit condition
; RMPR1 - array of HCPCS data from 661.1 file
; RMPR1("IEN") - ien of HCPCS in 661.1 (null if not found)
; RMPR1("HCPCS") - HCPCS code
; RMPR1("SHORT DESC") - HCPCS short description
; RMPR11 - array of Inventory Item data from 661.11 file
;
LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR1,RMPR11) ;
N RMPRMAX,RMPRLIN,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA,RMPRH
N RMPRERR,RMPRHA,RMPR1N,RMPRH2,RMPRHTXT,RMPRITXT
S RMPREXC=""
S (RMPR1("IEN"),RMPR11("IEN"))=""
S RMPRMAX=5
S RMPRLIN=0
S RMPRHTXT=$P(RMPRTXT,"-",1)
S RMPRITXT=""
I RMPRHTXT="" S RMPRH="" G LIKEA1
;
; Check for exact match and skip selection if it is
I $D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHTXT)) D G LIKEG
. S RMPRITXT=$P(RMPRTXT,"-",2)
. Q
;
; Check for unique partial match and skip selection if it is
S RMPRH=$O(^RMPR(661.11,"ASHI",RMPRSTN,RMPRTXT))
I $E(RMPRH,1,$L(RMPRTXT))'=RMPRTXT G LIKEC
S RMPRH2=$O(^RMPR(661.11,"ASHI",RMPRSTN,RMPRH))
I $E(RMPRH2,1,$L(RMPRTXT))'=RMPRTXT D G LIKEG
. W $E(RMPRH,1+$L(RMPRTXT),$L(RMPRH))
. S RMPRHTXT=RMPRH
. Q
G LIKEA3
;
; List partial matches
LIKEA1 S RMPRH=$O(^RMPR(661.11,"ASHI",RMPRSTN,RMPRH))
I RMPRH="" G:'RMPRLIN LIKEX G LIKEB
I $E(RMPRH,1,$L(RMPRTXT))'=RMPRTXT K DIR("A",1) G LIKEB
LIKEA2 I RMPRLIN,'(RMPRLIN#RMPRMAX) D G LIKEB
. S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
. Q
LIKEA3 K RMPRHA S RMPRHA("HCPCS")=RMPRH
S RMPRERR=$$HPACT^RMPRPIX1(.RMPRHA)
S RMPRLIN=RMPRLIN+1
W !?4,$J(RMPRLIN,2),?9,RMPRH,?19,RMPRHA("SHORT DESC")
S RMPRA(RMPRLIN)=RMPRH
G LIKEA1
LIKEB S DIR(0)="NAO"
S DIR("A")="Choose 1 - "_RMPRLIN_" : "
;S DIR("?")="^D LIKEH^RMPRPIYC"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G LIKEX
I $D(DIROUT) S RMPREXC="P" G LIKEX
I X="",$D(DIR("A",1)) S RMPREXC="" K DIR("A",1) G LIKEA3
I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G LIKEX
I $G(X),'$D(RMPRA(X)) W !!,"Please enter a number within the range." G LIKEB
I '$D(RMPRA(X)) W !!,"This response must be a number." G LIKEB
S RMPRHTXT=RMPRA(X)
;
; read in HCPCS and possibly Item as well
LIKEG K RMPR1
S RMPR1("HCPCS")=RMPRHTXT
S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
I RMPRITXT'="",$D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHTXT,RMPRITXT)) D
. K RMPR11
. S RMPR11("STATION")=RMPRSTN
. S RMPR11("HCPCS")=RMPRHTXT
. S RMPR11("ITEM")=RMPRITXT
. S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
. Q
G LIKEX
;
; If can't find HCPCS in PIP files use old DIC lookup
LIKEC D HCDIC(RMPRSTN,RMPRTXT,.RMPR1N)
I $G(RMPR1N("IEN"))'="" K RMPR1 M RMPR1=RMPR1N
;
;exit
LIKEX Q
LIKEH D QM,QM1H
Q
;
; Call DIC to match on text if not a HCPCS code
HCDIC(RMPRSTN,RMPRTXT,RMPR1) ;
N X,Y,DA,DIC
S DIC="^RMPR(661.1,"
S DIC(0)="EMQ"
S DIC("S")="I $$HCMAT^RMPRPIYC()"
S X=RMPRTXT
D ^DIC
I +Y'>0!($D(DTOUT))!($D(DUOUT)) G HCDICX
I $P(Y,"^",2)'="",$D(^RMPR(661.4,"XSHIL",RMPRSTN,$P(Y,"^",2))) D
. S RMPR1("HCPCS")=$P(Y,"^",2)
. S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
. Q
HCDICX Q
;
;***** HCMAT - extrinsic called from DIC call to screen out
; HCPCS not associated with PIP
; RMPRSTN (station ien) must be set
HCMAT() ;
N RMPRMAT
S RMPRMAT=0
I $D(^RMPR(661.4,"XSHIL",RMPRSTN,$P(^RMPR(661.1,Y,0),"^",1))) S RMPRMAT=1
HCMATX Q RMPRMAT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYC 5624 printed Sep 15, 2024@22:01:02 Page 2
RMPRPIYC ;HINCIO/ODJ - PIP HCPCS Prompt utilities ;3/8/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 QUIT
+3 ;
+4 ;***** HCPCS - Prompt for HCPCS called by reconciliation option
+5 ; (RMPRPIYA)
HCPCS(RMPR5,RMPR1,RMPR11,RMPREXC) ;
+1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT,DIC,DA,RMPRSTN,RMPRLCN,RMPR1N
+2 NEW RMPRYN
+3 SET DIR("A")="Select HCPCS to RECONCILE: "
+4 SET RMPRERR=0
+5 SET RMPREXC=""
+6 SET RMPR1("HCPCS")=$GET(RMPR1("HCPCS"))
+7 SET RMPRSTN=RMPR5("STATION")
+8 SET RMPRLCN=RMPR5("IEN")
+9 SET DIR(0)="FOA"
+10 SET DIR("?")="^D QM^RMPRPIYC"
+11 SET DIR("??")="^D QM2^RMPRPIYC"
HCPCS1 KILL RMPR1N
DO ^DIR
+1 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO HCPCSX
+2 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO HCPCSX
+3 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO HCPCSX
+4 DO LIKE^RMPRPIYC(RMPRSTN,X,.RMPREXC,.RMPR1N,.RMPR11)
+5 IF RMPREXC'=""
GOTO HCPCS1
+6 IF $GET(RMPR1N("IEN"))'=""
GOTO HCPCSU
+7 GOTO HCPCS1
HCPCSU KILL RMPR1
MERGE RMPR1=RMPR1N
HCPCSX QUIT RMPRERR
+1 ;
+2 ;***** QM - Single ? Help
+3 ; RMPRSTN required (see below QM2)
+4 ;
QM ; ask if want to list HCPCS
DO QM1
+1 IF RMPREXC'=""
GOTO QMX
+2 IF RMPRYN="N"
GOTO QMX
+3 ;list HCPCS
DO QM2
QMX QUIT
QM1 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT
+1 ;S DIR("A",1)=" Answer with PSAS HCPCS, or SHORT NAME, or CPT, or SYNONYM, or"
+2 ;S DIR("A",2)=" DESCRIPTION"
+3 SET DIR("A",1)="This response must be a number."
+4 SET DIR("A")="Do you want the entire list of PSAS HCPCS in inventory "
+5 SET DIR("?")="^D QM1H^RMPRPIYC"
+6 SET DIR(0)="YO"
+7 DO ^DIR
+8 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO QM1X
+9 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO QM1X
+10 IF X=""!(X["^")!($DATA(DUOUT))
SET RMPREXC="^"
GOTO QM1X
+11 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
+12 SET RMPREXC=""
QM1X QUIT
QM1H SET %A="V"
SET X="^"
+1 QUIT
+2 ;
+3 ;***** QM2 - List HCPCS associated with a Location
+4 ; called from a ?? help or Yes to the
+5 ; question in the ? help.
+6 ;
+7 ; requires RMPRSTN - Station ien
+8 ;
QM2 DO LIKE(RMPRSTN,"",.RMPREXC,.RMPR1N,.RMPR11)
+1 IF $GET(RMPR1N("IEN"))'=""
DO QM1H
QM2X QUIT
+1 ;
+2 ; ***** LIKE
+3 ; Handle the various inputs from a HCPCS prompt where HCPCS is
+4 ; being selected from PIP as opposed to the general
+5 ; HCPCS file 661.1
+6 ; This version uses the 661.11 file so any HCPCS that has been
+7 ; used in inventory can be selected.
+8 ;
+9 ; Inputs:
+10 ; RMPRSTN - Station ien
+11 ; RMPRTXT - Text entered at HCPCS prompt (cannot be null)
+12 ;
+13 ; Outputs:
+14 ; RMPREXC - exit condition
+15 ; RMPR1 - array of HCPCS data from 661.1 file
+16 ; RMPR1("IEN") - ien of HCPCS in 661.1 (null if not found)
+17 ; RMPR1("HCPCS") - HCPCS code
+18 ; RMPR1("SHORT DESC") - HCPCS short description
+19 ; RMPR11 - array of Inventory Item data from 661.11 file
+20 ;
LIKE(RMPRSTN,RMPRTXT,RMPREXC,RMPR1,RMPR11) ;
+1 NEW RMPRMAX,RMPRLIN,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA,RMPRH
+2 NEW RMPRERR,RMPRHA,RMPR1N,RMPRH2,RMPRHTXT,RMPRITXT
+3 SET RMPREXC=""
+4 SET (RMPR1("IEN"),RMPR11("IEN"))=""
+5 SET RMPRMAX=5
+6 SET RMPRLIN=0
+7 SET RMPRHTXT=$PIECE(RMPRTXT,"-",1)
+8 SET RMPRITXT=""
+9 IF RMPRHTXT=""
SET RMPRH=""
GOTO LIKEA1
+10 ;
+11 ; Check for exact match and skip selection if it is
+12 IF $DATA(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHTXT))
Begin DoDot:1
+13 SET RMPRITXT=$PIECE(RMPRTXT,"-",2)
+14 QUIT
End DoDot:1
GOTO LIKEG
+15 ;
+16 ; Check for unique partial match and skip selection if it is
+17 SET RMPRH=$ORDER(^RMPR(661.11,"ASHI",RMPRSTN,RMPRTXT))
+18 IF $EXTRACT(RMPRH,1,$LENGTH(RMPRTXT))'=RMPRTXT
GOTO LIKEC
+19 SET RMPRH2=$ORDER(^RMPR(661.11,"ASHI",RMPRSTN,RMPRH))
+20 IF $EXTRACT(RMPRH2,1,$LENGTH(RMPRTXT))'=RMPRTXT
Begin DoDot:1
+21 WRITE $EXTRACT(RMPRH,1+$LENGTH(RMPRTXT),$LENGTH(RMPRH))
+22 SET RMPRHTXT=RMPRH
+23 QUIT
End DoDot:1
GOTO LIKEG
+24 GOTO LIKEA3
+25 ;
+26 ; List partial matches
LIKEA1 SET RMPRH=$ORDER(^RMPR(661.11,"ASHI",RMPRSTN,RMPRH))
+1 IF RMPRH=""
if 'RMPRLIN
GOTO LIKEX
GOTO LIKEB
+2 IF $EXTRACT(RMPRH,1,$LENGTH(RMPRTXT))'=RMPRTXT
KILL DIR("A",1)
GOTO LIKEB
LIKEA2 IF RMPRLIN
IF '(RMPRLIN#RMPRMAX)
Begin DoDot:1
+1 SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
+2 QUIT
End DoDot:1
GOTO LIKEB
LIKEA3 KILL RMPRHA
SET RMPRHA("HCPCS")=RMPRH
+1 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPRHA)
+2 SET RMPRLIN=RMPRLIN+1
+3 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,RMPRH,?19,RMPRHA("SHORT DESC")
+4 SET RMPRA(RMPRLIN)=RMPRH
+5 GOTO LIKEA1
LIKEB SET DIR(0)="NAO"
+1 SET DIR("A")="Choose 1 - "_RMPRLIN_" : "
+2 ;S DIR("?")="^D LIKEH^RMPRPIYC"
+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))
SET RMPREXC=""
KILL DIR("A",1)
GOTO LIKEA3
+7 IF X=""!(X["^")!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+8 IF $GET(X)
IF '$DATA(RMPRA(X))
WRITE !!,"Please enter a number within the range."
GOTO LIKEB
+9 IF '$DATA(RMPRA(X))
WRITE !!,"This response must be a number."
GOTO LIKEB
+10 SET RMPRHTXT=RMPRA(X)
+11 ;
+12 ; read in HCPCS and possibly Item as well
LIKEG KILL RMPR1
+1 SET RMPR1("HCPCS")=RMPRHTXT
+2 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
+3 IF RMPRITXT'=""
IF $DATA(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHTXT,RMPRITXT))
Begin DoDot:1
+4 KILL RMPR11
+5 SET RMPR11("STATION")=RMPRSTN
+6 SET RMPR11("HCPCS")=RMPRHTXT
+7 SET RMPR11("ITEM")=RMPRITXT
+8 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
+9 QUIT
End DoDot:1
+10 GOTO LIKEX
+11 ;
+12 ; If can't find HCPCS in PIP files use old DIC lookup
LIKEC DO HCDIC(RMPRSTN,RMPRTXT,.RMPR1N)
+1 IF $GET(RMPR1N("IEN"))'=""
KILL RMPR1
MERGE RMPR1=RMPR1N
+2 ;
+3 ;exit
LIKEX QUIT
LIKEH DO QM
DO QM1H
+1 QUIT
+2 ;
+3 ; Call DIC to match on text if not a HCPCS code
HCDIC(RMPRSTN,RMPRTXT,RMPR1) ;
+1 NEW X,Y,DA,DIC
+2 SET DIC="^RMPR(661.1,"
+3 SET DIC(0)="EMQ"
+4 SET DIC("S")="I $$HCMAT^RMPRPIYC()"
+5 SET X=RMPRTXT
+6 DO ^DIC
+7 IF +Y'>0!($DATA(DTOUT))!($DATA(DUOUT))
GOTO HCDICX
+8 IF $PIECE(Y,"^",2)'=""
IF $DATA(^RMPR(661.4,"XSHIL",RMPRSTN,$PIECE(Y,"^",2)))
Begin DoDot:1
+9 SET RMPR1("HCPCS")=$PIECE(Y,"^",2)
+10 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
+11 QUIT
End DoDot:1
HCDICX QUIT
+1 ;
+2 ;***** HCMAT - extrinsic called from DIC call to screen out
+3 ; HCPCS not associated with PIP
+4 ; RMPRSTN (station ien) must be set
HCMAT() ;
+1 NEW RMPRMAT
+2 SET RMPRMAT=0
+3 IF $DATA(^RMPR(661.4,"XSHIL",RMPRSTN,$PIECE(^RMPR(661.1,Y,0),"^",1)))
SET RMPRMAT=1
HCMATX QUIT RMPRMAT
