- RMPRPIYP ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/30/02 13:35
- ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- Q
- ; The following subroutines are for selecting
- ; Inventory Item
- ;
- ;***** OK - Prompt for an OK
- OK(RMPRYN,RMPREXC) ;
- N DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
- S RMPREXC=""
- S RMPRYN="N"
- S DIR("A")=" ...OK"
- S DIR("B")="Yes"
- S DIR(0)="Y"
- D ^DIR
- I $D(DTOUT) S RMPREXC="T" G OKX
- I $D(DIROUT) S RMPREXC="P" G OKX
- I X=""!(X["^") S RMPREXC="^" G OKX
- S RMPRYN="N" S:Y RMPRYN="Y"
- OKX Q
- ;
- ;***** ITEM - Prompt for Inventory Item
- ITEM(RMPRSTN,RMPRHCPC,RMPR11,RMPREXC) ;
- N RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRIMA,RMPRGBLR
- N RMPRMAX,RMPRLIN,RMPRGBL,RMPR1,RMPRIMAD
- REDO S RMPRERR=0
- S RMPREXC=""
- I $G(RMPRSTN)="" S RMPRERR=1 G ITEMX
- I $G(RMPRHCPC)="" S RMPRERR=3 G ITEMX
- S RMPR1("HCPCS")=RMPRHCPC
- S RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
- K RMPR11
- S RMPRMAX=14
- S (RMLINE,RMPRLIN)=0
- S RMPRIMA=""
- ;
- ; See if just 1 item - no need to list if there is
- S RMPRGBLR="^RMPR(661.11,""ASHI"","_RMPRSTN_","""_RMPRHCPC_""")"
- S RMPRGBL=$Q(@RMPRGBLR)
- S RMPR11("IEN")=$QS(RMPRGBL,6)
- I $$ITEME() G ITEMX
- S RMPRGBL=$Q(@RMPRGBL)
- I $$ITEME() S RMPRERR=$$GET^RMPRPIX1(.RMPR11) G ITEMX
- ;
- ; Selection list of items if more than 1
- S RMPRGBL=RMPRGBLR
- ITEML1 S RMPRGBL=$Q(@RMPRGBL)
- I $$ITEME G:'RMPRLIN ITEMX G ITEMP
- I RMPRLIN,(RMLINE>RMPRMAX) D G ITEMP
- . S DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
- . Q
- ITEML2 ;
- S RMPR11("IEN")=$QS(RMPRGBL,6)
- S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- I RMPR11("STATUS")="INACTIVE" G ITEML1
- S RMPRLIN=RMPRLIN+1
- I RMPRIMA'=$QS(RMPRGBL,5) D
- . S RMPRIMAD=RMPR11("ITEM MASTER")
- . S RMPRIMA=$QS(RMPRGBL,5)
- . I RMPRLIN=1 Q
- . W !!,"IFCAP Item: ",RMPRIMAD
- .; S RMPRLIN=RMPRLIN+2,RMLINE=RMLINE+3
- . S RMLINE=RMLINE+3
- . Q
- I RMPRLIN=1 D ITEMH
- W !,$J(RMPRLIN,2)," ",RMPR11("HCPCS-ITEM")
- W ?16,$E(RMPR11("SOURCE"))_" "_RMPR11("DESCRIPTION")
- S RMPRA(RMPRLIN)=RMPR11("IEN")
- K RMPR11
- G ITEML1
- ;
- ; Prompt for selection
- ITEMP S DIR(0)="NAO"
- S DIR("A")="Choose 1 - "_RMPRLIN_" : "
- S (RMPRFLG,RMLINE)=0
- D ^DIR
- I $D(DTOUT) S RMPREXC="T" G ITEMX
- I $D(DIROUT) S RMPREXC="P" G ITEMX
- I X="",$D(DIR("A",1)) K DIR("A",1) D ITEMH G ITEML2
- ;I X="" S RMPREXC="^" G ITEMX
- I X["^"!($D(DUOUT)) S RMPREXC="^" G ITEMX
- I X'="",'$D(RMPRA(X)) S RMPRFLG=1
- I X="?"!X="??"!X="???" K RMPRA G REDO
- I (X="")!(RMPRFLG) D G ITEMP
- . W !,"Please select an item by entering a line number in range 1 - "
- . W RMPRLIN_" or '^' to EXIT"
- . S RMPRFLG=0
- . Q
- S RMPR11("IEN")=RMPRA(X)
- S RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- ITEMX Q
- ITEME() ;
- Q:$QS(RMPRGBL,1)'=661.11 1
- Q:$QS(RMPRGBL,2)'="ASHI" 1
- Q:$QS(RMPRGBL,3)'=RMPRSTN 1
- Q:$QS(RMPRGBL,4)'=RMPRHCPC 1
- Q 0
- ITEMH W !!,"HCPCS: "_RMPRHCPC_" "_RMPR1("SHORT DESC")
- W !," is associated with more than 1 item, please select one..."
- W !!,"IFCAP Item: ",RMPRIMAD
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYP 2963 printed Feb 19, 2025@00:03:40 Page 2
- RMPRPIYP ;HINCIO/ODJ - PIP EDIT - PROMPTS ;9/30/02 13:35
- +1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
- +2 QUIT
- +3 ; The following subroutines are for selecting
- +4 ; Inventory Item
- +5 ;
- +6 ;***** OK - Prompt for an OK
- OK(RMPRYN,RMPREXC) ;
- +1 NEW DIR,X,Y,DA,DUOUT,DTOUT,DIROUT,DIRUT
- +2 SET RMPREXC=""
- +3 SET RMPRYN="N"
- +4 SET DIR("A")=" ...OK"
- +5 SET DIR("B")="Yes"
- +6 SET DIR(0)="Y"
- +7 DO ^DIR
- +8 IF $DATA(DTOUT)
- SET RMPREXC="T"
- GOTO OKX
- +9 IF $DATA(DIROUT)
- SET RMPREXC="P"
- GOTO OKX
- +10 IF X=""!(X["^")
- SET RMPREXC="^"
- GOTO OKX
- +11 SET RMPRYN="N"
- if Y
- SET RMPRYN="Y"
- OKX QUIT
- +1 ;
- +2 ;***** ITEM - Prompt for Inventory Item
- ITEM(RMPRSTN,RMPRHCPC,RMPR11,RMPREXC) ;
- +1 NEW RMPRERR,DIR,X,Y,DUOUT,DTOUT,DIROUT,DA,DIRUT,RMPRA,RMPRIMA,RMPRGBLR
- +2 NEW RMPRMAX,RMPRLIN,RMPRGBL,RMPR1,RMPRIMAD
- REDO SET RMPRERR=0
- +1 SET RMPREXC=""
- +2 IF $GET(RMPRSTN)=""
- SET RMPRERR=1
- GOTO ITEMX
- +3 IF $GET(RMPRHCPC)=""
- SET RMPRERR=3
- GOTO ITEMX
- +4 SET RMPR1("HCPCS")=RMPRHCPC
- +5 SET RMPRERR=$$HPACT^RMPRPIX1(.RMPR1)
- +6 KILL RMPR11
- +7 SET RMPRMAX=14
- +8 SET (RMLINE,RMPRLIN)=0
- +9 SET RMPRIMA=""
- +10 ;
- +11 ; See if just 1 item - no need to list if there is
- +12 SET RMPRGBLR="^RMPR(661.11,""ASHI"","_RMPRSTN_","""_RMPRHCPC_""")"
- +13 SET RMPRGBL=$QUERY(@RMPRGBLR)
- +14 SET RMPR11("IEN")=$QSUBSCRIPT(RMPRGBL,6)
- +15 IF $$ITEME()
- GOTO ITEMX
- +16 SET RMPRGBL=$QUERY(@RMPRGBL)
- +17 IF $$ITEME()
- SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- GOTO ITEMX
- +18 ;
- +19 ; Selection list of items if more than 1
- +20 SET RMPRGBL=RMPRGBLR
- ITEML1 SET RMPRGBL=$QUERY(@RMPRGBL)
- +1 IF $$ITEME
- if 'RMPRLIN
- GOTO ITEMX
- GOTO ITEMP
- +2 IF RMPRLIN
- IF (RMLINE>RMPRMAX)
- Begin DoDot:1
- +3 SET DIR("A",1)="Press <RETURN> to see more, '^' to exit this list, or"
- +4 QUIT
- End DoDot:1
- GOTO ITEMP
- ITEML2 ;
- +1 SET RMPR11("IEN")=$QSUBSCRIPT(RMPRGBL,6)
- +2 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- +3 IF RMPR11("STATUS")="INACTIVE"
- GOTO ITEML1
- +4 SET RMPRLIN=RMPRLIN+1
- +5 IF RMPRIMA'=$QSUBSCRIPT(RMPRGBL,5)
- Begin DoDot:1
- +6 SET RMPRIMAD=RMPR11("ITEM MASTER")
- +7 SET RMPRIMA=$QSUBSCRIPT(RMPRGBL,5)
- +8 IF RMPRLIN=1
- QUIT
- +9 WRITE !!,"IFCAP Item: ",RMPRIMAD
- +10 ; S RMPRLIN=RMPRLIN+2,RMLINE=RMLINE+3
- +11 SET RMLINE=RMLINE+3
- +12 QUIT
- End DoDot:1
- +13 IF RMPRLIN=1
- DO ITEMH
- +14 WRITE !,$JUSTIFY(RMPRLIN,2)," ",RMPR11("HCPCS-ITEM")
- +15 WRITE ?16,$EXTRACT(RMPR11("SOURCE"))_" "_RMPR11("DESCRIPTION")
- +16 SET RMPRA(RMPRLIN)=RMPR11("IEN")
- +17 KILL RMPR11
- +18 GOTO ITEML1
- +19 ;
- +20 ; Prompt for selection
- ITEMP SET DIR(0)="NAO"
- +1 SET DIR("A")="Choose 1 - "_RMPRLIN_" : "
- +2 SET (RMPRFLG,RMLINE)=0
- +3 DO ^DIR
- +4 IF $DATA(DTOUT)
- SET RMPREXC="T"
- GOTO ITEMX
- +5 IF $DATA(DIROUT)
- SET RMPREXC="P"
- GOTO ITEMX
- +6 IF X=""
- IF $DATA(DIR("A",1))
- KILL DIR("A",1)
- DO ITEMH
- GOTO ITEML2
- +7 ;I X="" S RMPREXC="^" G ITEMX
- +8 IF X["^"!($DATA(DUOUT))
- SET RMPREXC="^"
- GOTO ITEMX
- +9 IF X'=""
- IF '$DATA(RMPRA(X))
- SET RMPRFLG=1
- +10 IF X="?"!X="??"!X="???"
- KILL RMPRA
- GOTO REDO
- +11 IF (X="")!(RMPRFLG)
- Begin DoDot:1
- +12 WRITE !,"Please select an item by entering a line number in range 1 - "
- +13 WRITE RMPRLIN_" or '^' to EXIT"
- +14 SET RMPRFLG=0
- +15 QUIT
- End DoDot:1
- GOTO ITEMP
- +16 SET RMPR11("IEN")=RMPRA(X)
- +17 SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
- ITEMX QUIT
- ITEME() ;
- +1 if $QSUBSCRIPT(RMPRGBL,1)'=661.11
- QUIT 1
- +2 if $QSUBSCRIPT(RMPRGBL,2)'="ASHI"
- QUIT 1
- +3 if $QSUBSCRIPT(RMPRGBL,3)'=RMPRSTN
- QUIT 1
- +4 if $QSUBSCRIPT(RMPRGBL,4)'=RMPRHCPC
- QUIT 1
- +5 QUIT 0
- ITEMH WRITE !!,"HCPCS: "_RMPRHCPC_" "_RMPR1("SHORT DESC")
- +1 WRITE !," is associated with more than 1 item, please select one..."
- +2 WRITE !!,"IFCAP Item: ",RMPRIMAD
- +3 QUIT