- RMPRPIY8 ;HINCIO/ODJ - Pick HCPCS Item ;3/8/01
- ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- Q
- ;
- ; ? Help
- QM W ?4,"Answer with ITEM, or NUMBER, or DESCRIPTION"
- W !?3,"Choose from:"
- D QM2
- Q
- ;
- ; ?? Help
- QQM W !?3,"Choose from:"
- D QM2
- Q
- QM2 N DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
- S RMPRMAX=5,RMPRLIN=0
- S RMPREXC=""
- S DIR(0)="EA"
- S DIR("A")="'^' TO STOP: "
- S RMPRI=""
- QM2A S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
- I RMPRI="" G QM2X
- K RMPR
- S RMPR("STATION")=RMPRSTN
- S RMPR("HCPCS")=RMPRHCPC
- S RMPR("ITEM")=RMPRI
- S RMPRERR=$$GET^RMPRPIX1(.RMPR)
- S RMPRLIN=RMPRLIN+1
- W !?3,RMPRLIN,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
- I RMPRLIN'<RMPRMAX G QM2B
- G QM2A
- QM2B D ^DIR
- I $D(DTOUT) S RMPREXC="T" G QM2X
- I $D(DIROUT) S RMPREXC="P" G QM2X
- I X=""!(X["^")!$D(DUOUT) S RMPREXC="^" G QM2X
- QM2X Q
- ;
- ;
- LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11,RMPR4) ;
- N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
- N RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA,RMPRI,RMPRIEN,RMPRH
- S RMPREXC=""
- S RMPRMAX=5
- S RMPR4("IEN")=""
- ;
- ; NUMBER entered
- ; loop on index until count=entered number
- I RMPRTXT?1.N D G LIKEX
- . S RMPRLIN=0
- . S RMPRI=""
- . F S RMPRI=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI)) Q:RMPRI="" D Q:RMPR4("IEN")'=""
- .. S RMPRLIN=RMPRLIN+1
- .. I RMPRLIN=RMPRTXT D
- ... S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI,""))
- ... S RMPR4("IEN")=RMPRIEN
- ... K RMPR11
- ... S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
- ... S RMPR11("STATION")=RMPRSTN
- ... S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- ... Q
- .. Q
- . Q
- ;
- ; ITEM entered (HCPCS-ITEM form eg. L5000-3)
- S RMPRH=$P(RMPRTXT,"-",1)
- I $E(RMPRHCPC,1,$L(RMPRH))=RMPRH G LIKEH1 ;use 661.4 index
- ;
- ; DESCRIPTION entered - use 661.11 index
- S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
- LIKEA1 K RMPRA S RMPRLIN=0
- LIKEA S RMPRGBL=$Q(@RMPRGBL)
- I RMPRGBL="" G LIKEB
- I $QS(RMPRGBL,1)'=661.11 G LIKEB
- I $QS(RMPRGBL,2)'="ASHD" G LIKEB
- I $QS(RMPRGBL,3)'=RMPRSTN G LIKEB
- I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
- I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
- K RMPR
- S RMPR("IEN")=$QS(RMPRGBL,6)
- S RMPRERR=$$GET^RMPRPIX1(.RMPR) ;read 661.11 file
- I '$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"))) G LIKEA ;item not in selected location
- S RMPRLIN=RMPRLIN+1
- W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5),?40,RMPR("HCPCS-ITEM")
- S RMPRIEN=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"),""))
- S RMPRA(RMPRLIN)=RMPRIEN
- I RMPRLIN'<RMPRMAX G LIKEB
- G LIKEA
- LIKEB I RMPRLIN=0 G LIKEX
- S DIR(0)="NAO^1:"_RMPRLIN_": "
- S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
- D ^DIR
- W !
- I $D(DTOUT) S RMPREXC="T" G LIKEX
- I $D(DIROUT) S RMPREXC="P" G LIKEX
- I X="" S RMPREXC="" G LIKEA
- I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
- K RMPR11
- S RMPR4("IEN")=RMPRA(X)
- S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
- S RMPR11("STATION")=RMPRSTN
- S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- G LIKEX
- ;
- ;
- LIKEH1 S RMPRI=$P(RMPRTXT,"-",2)
- I RMPRI'="",$D(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI)) D G LIKEH9A
- . S RMPR4("IEN")=$O(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI,""))
- . Q
- S RMPRGBL="^RMPR(661.4,"_"""ASLHI"","_RMPRSTN_","_RMPRLCN_","""_RMPRH_""")"
- K RMPRA S RMPRLIN=0
- LIKEH S RMPRGBL=$Q(@RMPRGBL)
- I RMPRGBL="" G LIKEH9
- I $QS(RMPRGBL,1)'=661.4 G LIKEH9
- I $QS(RMPRGBL,2)'="ASLHI" G LIKEH9
- I $QS(RMPRGBL,3)'=RMPRSTN G LIKEH9
- I $QS(RMPRGBL,4)'=RMPRLCN G LIKEH9
- I $QS(RMPRGBL,5)'=RMPRHCPC G LIKEH
- S RMPR("IEN")=$QS(RMPRGBL,7)
- K RMPR11
- S RMPRERR=$$GET^RMPRPIX4(.RMPR,.RMPR11,)
- S RMPR11("STATION")=RMPRSTN
- S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- S RMPRLIN=RMPRLIN+1
- W !?4,$J(RMPRLIN,2),?9,RMPR11("HCPCS-ITEM"),?23,RMPR11("DESCRIPTION")
- S RMPRA(RMPRLIN)=$QS(RMPRGBL,7)
- I RMPRLIN'<RMPRMAX G LIKEH9
- G LIKEH
- LIKEH9 I RMPRLIN=0 G LIKEX
- S DIR(0)="NAO^1:"_RMPRLIN_": "
- S DIR("A")="CHOOSE 1-"_RMPRLIN_": "
- D ^DIR
- W !
- I $D(DTOUT) S RMPREXC="T" G LIKEX
- I $D(DIROUT) S RMPREXC="P" G LIKEX
- I X="" S RMPREXC="" G LIKEH
- I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
- S RMPR4("IEN")=RMPRA(X)
- LIKEH9A K RMPR11
- S RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
- S RMPR11("STATION")=RMPRSTN
- S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- G LIKEX
- ;exit
- LIKEX Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIY8 4384 printed Feb 19, 2025@00:03:24 Page 2
- RMPRPIY8 ;HINCIO/ODJ - Pick HCPCS Item ;3/8/01
- +1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- +2 QUIT
- +3 ;
- +4 ; ? Help
- QM WRITE ?4,"Answer with ITEM, or NUMBER, or DESCRIPTION"
- +1 WRITE !?3,"Choose from:"
- +2 DO QM2
- +3 QUIT
- +4 ;
- +5 ; ?? Help
- QQM WRITE !?3,"Choose from:"
- +1 DO QM2
- +2 QUIT
- QM2 NEW DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRMAX,RMPRI,RMPRLIN,RMPR,RMPRERR
- +1 SET RMPRMAX=5
- SET RMPRLIN=0
- +2 SET RMPREXC=""
- +3 SET DIR(0)="EA"
- +4 SET DIR("A")="'^' TO STOP: "
- +5 SET RMPRI=""
- QM2A SET RMPRI=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
- +1 IF RMPRI=""
- GOTO QM2X
- +2 KILL RMPR
- +3 SET RMPR("STATION")=RMPRSTN
- +4 SET RMPR("HCPCS")=RMPRHCPC
- +5 SET RMPR("ITEM")=RMPRI
- +6 SET RMPRERR=$$GET^RMPRPIX1(.RMPR)
- +7 SET RMPRLIN=RMPRLIN+1
- +8 WRITE !?3,RMPRLIN,?16,RMPR("HCPCS-ITEM"),?28,RMPR("DESCRIPTION")
- +9 IF RMPRLIN'<RMPRMAX
- GOTO QM2B
- +10 GOTO QM2A
- QM2B DO ^DIR
- +1 IF $DATA(DTOUT)
- SET RMPREXC="T"
- GOTO QM2X
- +2 IF $DATA(DIROUT)
- SET RMPREXC="P"
- GOTO QM2X
- +3 IF X=""!(X["^")!$DATA(DUOUT)
- SET RMPREXC="^"
- GOTO QM2X
- QM2X QUIT
- +1 ;
- +2 ;
- LIKE(RMPRSTN,RMPRLCN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11,RMPR4) ;
- +1 NEW RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
- +2 NEW RMPRERR,RMPRN,RMPRGBL,RMPR,RMPREXMA,RMPRI,RMPRIEN,RMPRH
- +3 SET RMPREXC=""
- +4 SET RMPRMAX=5
- +5 SET RMPR4("IEN")=""
- +6 ;
- +7 ; NUMBER entered
- +8 ; loop on index until count=entered number
- +9 IF RMPRTXT?1.N
- Begin DoDot:1
- +10 SET RMPRLIN=0
- +11 SET RMPRI=""
- +12 FOR
- SET RMPRI=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI))
- if RMPRI=""
- QUIT
- Begin DoDot:2
- +13 SET RMPRLIN=RMPRLIN+1
- +14 IF RMPRLIN=RMPRTXT
- Begin DoDot:3
- +15 SET RMPRIEN=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPRI,""))
- +16 SET RMPR4("IEN")=RMPRIEN
- +17 KILL RMPR11
- +18 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
- +19 SET RMPR11("STATION")=RMPRSTN
- +20 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- +21 QUIT
- End DoDot:3
- +22 QUIT
- End DoDot:2
- if RMPR4("IEN")'=""
- QUIT
- +23 QUIT
- End DoDot:1
- GOTO LIKEX
- +24 ;
- +25 ; ITEM entered (HCPCS-ITEM form eg. L5000-3)
- +26 SET RMPRH=$PIECE(RMPRTXT,"-",1)
- +27 ;use 661.4 index
- IF $EXTRACT(RMPRHCPC,1,$LENGTH(RMPRH))=RMPRH
- GOTO LIKEH1
- +28 ;
- +29 ; DESCRIPTION entered - use 661.11 index
- +30 SET RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
- LIKEA1 KILL RMPRA
- SET RMPRLIN=0
- LIKEA SET RMPRGBL=$QUERY(@RMPRGBL)
- +1 IF RMPRGBL=""
- GOTO LIKEB
- +2 IF $QSUBSCRIPT(RMPRGBL,1)'=661.11
- GOTO LIKEB
- +3 IF $QSUBSCRIPT(RMPRGBL,2)'="ASHD"
- GOTO LIKEB
- +4 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
- GOTO LIKEB
- +5 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRHCPC
- GOTO LIKEB
- +6 IF $EXTRACT($QSUBSCRIPT(RMPRGBL,5),1,$LENGTH(RMPRTXT))'=RMPRTXT
- GOTO LIKEB
- +7 KILL RMPR
- +8 SET RMPR("IEN")=$QSUBSCRIPT(RMPRGBL,6)
- +9 ;read 661.11 file
- SET RMPRERR=$$GET^RMPRPIX1(.RMPR)
- +10 ;item not in selected location
- IF '$DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM")))
- GOTO LIKEA
- +11 SET RMPRLIN=RMPRLIN+1
- +12 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,$QSUBSCRIPT(RMPRGBL,5),?40,RMPR("HCPCS-ITEM")
- +13 SET RMPRIEN=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRHCPC,RMPR("ITEM"),""))
- +14 SET RMPRA(RMPRLIN)=RMPRIEN
- +15 IF RMPRLIN'<RMPRMAX
- GOTO LIKEB
- +16 GOTO LIKEA
- LIKEB IF RMPRLIN=0
- GOTO LIKEX
- +1 SET DIR(0)="NAO^1:"_RMPRLIN_": "
- +2 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
- +3 DO ^DIR
- +4 WRITE !
- +5 IF $DATA(DTOUT)
- SET RMPREXC="T"
- GOTO LIKEX
- +6 IF $DATA(DIROUT)
- SET RMPREXC="P"
- GOTO LIKEX
- +7 IF X=""
- SET RMPREXC=""
- GOTO LIKEA
- +8 IF X["^"!$DATA(DUOUT)
- SET RMPREXC="^"
- GOTO LIKEX
- +9 KILL RMPR11
- +10 SET RMPR4("IEN")=RMPRA(X)
- +11 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
- +12 SET RMPR11("STATION")=RMPRSTN
- +13 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- +14 GOTO LIKEX
- +15 ;
- +16 ;
- LIKEH1 SET RMPRI=$PIECE(RMPRTXT,"-",2)
- +1 IF RMPRI'=""
- IF $DATA(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI))
- Begin DoDot:1
- +2 SET RMPR4("IEN")=$ORDER(^RMPR(661.4,"ASLHI",RMPRSTN,RMPRLCN,RMPRH,RMPRI,""))
- +3 QUIT
- End DoDot:1
- GOTO LIKEH9A
- +4 SET RMPRGBL="^RMPR(661.4,"_"""ASLHI"","_RMPRSTN_","_RMPRLCN_","""_RMPRH_""")"
- +5 KILL RMPRA
- SET RMPRLIN=0
- LIKEH SET RMPRGBL=$QUERY(@RMPRGBL)
- +1 IF RMPRGBL=""
- GOTO LIKEH9
- +2 IF $QSUBSCRIPT(RMPRGBL,1)'=661.4
- GOTO LIKEH9
- +3 IF $QSUBSCRIPT(RMPRGBL,2)'="ASLHI"
- GOTO LIKEH9
- +4 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
- GOTO LIKEH9
- +5 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRLCN
- GOTO LIKEH9
- +6 IF $QSUBSCRIPT(RMPRGBL,5)'=RMPRHCPC
- GOTO LIKEH
- +7 SET RMPR("IEN")=$QSUBSCRIPT(RMPRGBL,7)
- +8 KILL RMPR11
- +9 SET RMPRERR=$$GET^RMPRPIX4(.RMPR,.RMPR11,)
- +10 SET RMPR11("STATION")=RMPRSTN
- +11 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- +12 SET RMPRLIN=RMPRLIN+1
- +13 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,RMPR11("HCPCS-ITEM"),?23,RMPR11("DESCRIPTION")
- +14 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,7)
- +15 IF RMPRLIN'<RMPRMAX
- GOTO LIKEH9
- +16 GOTO LIKEH
- LIKEH9 IF RMPRLIN=0
- GOTO LIKEX
- +1 SET DIR(0)="NAO^1:"_RMPRLIN_": "
- +2 SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
- +3 DO ^DIR
- +4 WRITE !
- +5 IF $DATA(DTOUT)
- SET RMPREXC="T"
- GOTO LIKEX
- +6 IF $DATA(DIROUT)
- SET RMPREXC="P"
- GOTO LIKEX
- +7 IF X=""
- SET RMPREXC=""
- GOTO LIKEH
- +8 IF X["^"!$DATA(DUOUT)
- SET RMPREXC="^"
- GOTO LIKEX
- +9 SET RMPR4("IEN")=RMPRA(X)
- LIKEH9A KILL RMPR11
- +1 SET RMPRERR=$$GET^RMPRPIX4(.RMPR4,.RMPR11,)
- +2 SET RMPR11("STATION")=RMPRSTN
- +3 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- +4 GOTO LIKEX
- +5 ;exit
- LIKEX QUIT