RMPRPIYO ;HIN/RVD-PROS INVENTORY ORDER/RE-ORDER ;5/7/01
;;3.0;PROSTHETICS;**61**;Feb 09, 1996
D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
;
W @IOF
;ask for location
W !!,"Ordering ITEM from Supply or Vendor....",!
;
HCPC ;ask for HCPCS
S RMF=1
K DTOUT,DUOUT,DIC
S DIC("A")="Select HCPCS to ORDER: "
;
S DIC="^RMPR(661.11,",DIC(0)="AEMNQ"
S DIC("S")="S RZ=^RMPR(661.11,+Y,0),RH=$P(RZ,U,1),RI=$P(RZ,U,2),RT=$P(RZ,U,9),RE=$O(^RMPR(661.1,""B"",RH,0)) I $P(^RMPR(661.1,RE,0),U,5),RT'=1,($P(RZ,U,4)=RMPR(""STA""))"
S DIC("W")="I $D(^RMPR(661.11,+Y,0)) S RMZ=^RMPR(661.11,+Y,0) W "" "",$P(RMZ,U,7),"" "",$P(RMZ,U,3)"
W ! D ^DIC I $D(DUOUT)!$D(DTOUT)!(Y<0) G EXIT
S RMHCPC=$P(^RMPR(661.11,+Y,0),U,1)
S RMIDA=$P(^RMPR(661.11,+Y,0),U,2)
S RMHCDA=$O(^RMPR(661.1,"B",RMHCPC,0))
S RMPR11("HCPCS")=RMHCPC
S RMPR11("ITEM")=RMIDA
S RMPR11("STATION")=RMPR("STA")
;
VEN ;order item from vendor.
K DIR,Y S DIR(0)="661.41,4",DIR("A")="Enter Vendor" D ^DIR
I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G HCPC
I X="" W $C(7),!,"Enter Vendor from the Vendor file.." G VEN
S RMVEN=+Y K DIR,Y
;
;
ORDER ;order QUANTITY from vendor or supply.
K DIR,Y S DIR(0)="661.41,7",DIR("A")="Quantity to Order" D ^DIR
I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G HCPC
I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
S (RMPR6("QUANTITY"),RMORDER)=Y K DIR,Y
;
COM ;comments
K DIR,Y S DIR(0)="661.41,9",DIR("A")="Enter Comment" D ^DIR
I $D(DUOUT)!$D(DTOUT) G HCPC
S (RMPR6("COMMENT"),RMCOM)=Y
SET6 ;set-up 661.6 data
S RMPR6("VENDOR")=$G(RMVEN)
S RMPR6("TRAN TYPE")=2
S RMPR6("LOCATION")=""
S RMPR6("USER")=$G(DUZ)
S RMPR6("VALUE")=""
UP6 ;create file 661.6
S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
I $G(RMERR) W !,"*** Error in file 661.6 update!!!",! H 2 G HCPC
UPD ;update file 661.41
;
;D UPDATE^DIE("","RMDAT","","RMERR")
;call API for 661.41
L +^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
K RMERR,RMERROR
S DIE="^RMPR(661.41,"
S RMDAT(661.41,"+1,",.01)=DT
S RMDAT(661.41,"+1,",1)=RMPR11("ITEM")
S RMDAT(661.41,"+1,",2)=RMPR("STA")
S RMDAT(661.41,"+1,",4)=RMVEN
S RMDAT(661.41,"+1,",5)=RMPR11("HCPCS")
S RMDAT(661.41,"+1,",7)=RMORDER
S RMDAT(661.41,"+1,",9)=RMCOM
S RMDAT(661.41,"+1,",10)="O"
D UPDATE^DIE("","RMDAT","","RMERR") I $D(RMERR) S RMERROR=1
L -^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
I $G(RMERROR) W !,"*** Error in file 661.41 update!!!",!
I '$G(RMERROR) W !,"*** Item was ordered...."
H 1 G HCPC
;
; Prompt if adding a new HCPCS Item
OKADD(RMPR11,RMPRYN,RMPREXC) ;
N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
S RMPREXC="",DIR(0)="Y"
S DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
D ^DIR
I $D(DTOUT) S RMPREXC="T" G ADDNMX
I $D(DIROUT) S RMPREXC="P" G ADDNMX
I X=""!(X["^") S RMPREXC="^" G ADDNMX
S RMPRYN="N" S:Y RMPRYN="Y"
S RMPREXC=""
ADDNMX Q
;
LIKE(RMPRSTN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11) ;
N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
N RMPRERR,RMPRN
S RMPREXC="",RMPRMAX=19
S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
I $D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHCPC,RMPRTXT)) D G LIKEA
. S RMPRA(1)=$O(^RMPR(661.11,"ASHI",RMPR("STA"),RMPRHCPC,RMPRTXT,""))
. W !?5,1,?9,$P(^RMPR(661.11,RMPRA(1),0),"^",2)
. Q
LIKEA1 K RMPRA S RMPRLIN=0
LIKEA S RMPRGBL=$Q(@RMPRGBL)
I '$D(RMPRLIN) S RMPRLIN=0
I RMPRGBL="" G LIKEB
I $QS(RMPRGBL,1)'=661.11 G LIKEB
I $QS(RMPRGBL,2)'="ASHD" G LIKEB
I $QS(RMPRGBL,3)'=RMPR("STA") G LIKEB
I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
S RMPRLIN=RMPRLIN+1
W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5)
S RMPRA(RMPRLIN)=$QS(RMPRGBL,6)
I RMPRLIN'<RMPRMAX G LIKEB
G LIKEA
LIKEB I RMPRLIN=0 G LIKEX
S DIR(0)="NAO^1:"_RMPRLIN_": ",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 LIKEX
I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
K RMPR11
S RMPR11("IEN")=RMPRA(X),RMPRERR=$$GET^RMPRPIX1(.RMPR11)
LIKEX Q
;
LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
Q:'$G(RMF)!(X=" ")
S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
K RX
I $D(^RMPR(661.7,"XSHIDS",RMPR("STA"),X)) S RX=1
I '$G(RX),$D(^RMPR(661.1,"B",X)) D EN^DDIOL("*** Only PSAS HCPCS in PIP can be ordered. Please verify your Location and PSAS HCPCS!!","","!!")
K RX
Q
;
EXIT ;MAIN EXIT POINT
N RMPRSITE,RMPR D KILL^XUSCLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPIYO 4707 printed Nov 22, 2024@17:47:11 Page 2
RMPRPIYO ;HIN/RVD-PROS INVENTORY ORDER/RE-ORDER ;5/7/01
+1 ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
+2 DO DIV4^RMPRSIT
IF $DATA(Y)
IF (Y<0)
KILL DIC("B")
QUIT
+3 SET X="NOW"
DO ^%DT
DO DD^%DT
SET RMDAT=Y
+4 ;
+5 WRITE @IOF
+6 ;ask for location
+7 WRITE !!,"Ordering ITEM from Supply or Vendor....",!
+8 ;
HCPC ;ask for HCPCS
+1 SET RMF=1
+2 KILL DTOUT,DUOUT,DIC
+3 SET DIC("A")="Select HCPCS to ORDER: "
+4 ;
+5 SET DIC="^RMPR(661.11,"
SET DIC(0)="AEMNQ"
+6 SET DIC("S")="S RZ=^RMPR(661.11,+Y,0),RH=$P(RZ,U,1),RI=$P(RZ,U,2),RT=$P(RZ,U,9),RE=$O(^RMPR(661.1,""B"",RH,0)) I $P(^RMPR(661.1,RE,0),U,5),RT'=1,($P(RZ,U,4)=RMPR(""STA""))"
+7 SET DIC("W")="I $D(^RMPR(661.11,+Y,0)) S RMZ=^RMPR(661.11,+Y,0) W "" "",$P(RMZ,U,7),"" "",$P(RMZ,U,3)"
+8 WRITE !
DO ^DIC
IF $DATA(DUOUT)!$DATA(DTOUT)!(Y<0)
GOTO EXIT
+9 SET RMHCPC=$PIECE(^RMPR(661.11,+Y,0),U,1)
+10 SET RMIDA=$PIECE(^RMPR(661.11,+Y,0),U,2)
+11 SET RMHCDA=$ORDER(^RMPR(661.1,"B",RMHCPC,0))
+12 SET RMPR11("HCPCS")=RMHCPC
+13 SET RMPR11("ITEM")=RMIDA
+14 SET RMPR11("STATION")=RMPR("STA")
+15 ;
VEN ;order item from vendor.
+1 KILL DIR,Y
SET DIR(0)="661.41,4"
SET DIR("A")="Enter Vendor"
DO ^DIR
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
WRITE !,"*** Item was not ordered...."
HANG 1
GOTO HCPC
+3 IF X=""
WRITE $CHAR(7),!,"Enter Vendor from the Vendor file.."
GOTO VEN
+4 SET RMVEN=+Y
KILL DIR,Y
+5 ;
+6 ;
ORDER ;order QUANTITY from vendor or supply.
+1 KILL DIR,Y
SET DIR(0)="661.41,7"
SET DIR("A")="Quantity to Order"
DO ^DIR
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
WRITE !,"*** Item was not ordered...."
HANG 1
GOTO HCPC
+3 IF X=""
WRITE $CHAR(7),!,"Enter quantity 1 to 99999.."
GOTO ORDER
+4 SET (RMPR6("QUANTITY"),RMORDER)=Y
KILL DIR,Y
+5 ;
COM ;comments
+1 KILL DIR,Y
SET DIR(0)="661.41,9"
SET DIR("A")="Enter Comment"
DO ^DIR
+2 IF $DATA(DUOUT)!$DATA(DTOUT)
GOTO HCPC
+3 SET (RMPR6("COMMENT"),RMCOM)=Y
SET6 ;set-up 661.6 data
+1 SET RMPR6("VENDOR")=$GET(RMVEN)
+2 SET RMPR6("TRAN TYPE")=2
+3 SET RMPR6("LOCATION")=""
+4 SET RMPR6("USER")=$GET(DUZ)
+5 SET RMPR6("VALUE")=""
UP6 ;create file 661.6
+1 SET RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
+2 IF $GET(RMERR)
WRITE !,"*** Error in file 661.6 update!!!",!
HANG 2
GOTO HCPC
UPD ;update file 661.41
+1 ;
+2 ;D UPDATE^DIE("","RMDAT","","RMERR")
+3 ;call API for 661.41
+4 LOCK +^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
+5 KILL RMERR,RMERROR
+6 SET DIE="^RMPR(661.41,"
+7 SET RMDAT(661.41,"+1,",.01)=DT
+8 SET RMDAT(661.41,"+1,",1)=RMPR11("ITEM")
+9 SET RMDAT(661.41,"+1,",2)=RMPR("STA")
+10 SET RMDAT(661.41,"+1,",4)=RMVEN
+11 SET RMDAT(661.41,"+1,",5)=RMPR11("HCPCS")
+12 SET RMDAT(661.41,"+1,",7)=RMORDER
+13 SET RMDAT(661.41,"+1,",9)=RMCOM
+14 SET RMDAT(661.41,"+1,",10)="O"
+15 DO UPDATE^DIE("","RMDAT","","RMERR")
IF $DATA(RMERR)
SET RMERROR=1
+16 LOCK -^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
+17 IF $GET(RMERROR)
WRITE !,"*** Error in file 661.41 update!!!",!
+18 IF '$GET(RMERROR)
WRITE !,"*** Item was ordered...."
+19 HANG 1
GOTO HCPC
+20 ;
+21 ; Prompt if adding a new HCPCS Item
OKADD(RMPR11,RMPRYN,RMPREXC) ;
+1 NEW DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
+2 SET RMPREXC=""
SET DIR(0)="Y"
+3 SET DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
+4 DO ^DIR
+5 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO ADDNMX
+6 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO ADDNMX
+7 IF X=""!(X["^")
SET RMPREXC="^"
GOTO ADDNMX
+8 SET RMPRYN="N"
if Y
SET RMPRYN="Y"
+9 SET RMPREXC=""
ADDNMX QUIT
+1 ;
LIKE(RMPRSTN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11) ;
+1 NEW RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
+2 NEW RMPRERR,RMPRN
+3 SET RMPREXC=""
SET RMPRMAX=19
+4 SET RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
+5 IF $DATA(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHCPC,RMPRTXT))
Begin DoDot:1
+6 SET RMPRA(1)=$ORDER(^RMPR(661.11,"ASHI",RMPR("STA"),RMPRHCPC,RMPRTXT,""))
+7 WRITE !?5,1,?9,$PIECE(^RMPR(661.11,RMPRA(1),0),"^",2)
+8 QUIT
End DoDot:1
GOTO LIKEA
LIKEA1 KILL RMPRA
SET RMPRLIN=0
LIKEA SET RMPRGBL=$QUERY(@RMPRGBL)
+1 IF '$DATA(RMPRLIN)
SET RMPRLIN=0
+2 IF RMPRGBL=""
GOTO LIKEB
+3 IF $QSUBSCRIPT(RMPRGBL,1)'=661.11
GOTO LIKEB
+4 IF $QSUBSCRIPT(RMPRGBL,2)'="ASHD"
GOTO LIKEB
+5 IF $QSUBSCRIPT(RMPRGBL,3)'=RMPR("STA")
GOTO LIKEB
+6 IF $QSUBSCRIPT(RMPRGBL,4)'=RMPRHCPC
GOTO LIKEB
+7 IF $EXTRACT($QSUBSCRIPT(RMPRGBL,5),1,$LENGTH(RMPRTXT))'=RMPRTXT
GOTO LIKEB
+8 SET RMPRLIN=RMPRLIN+1
+9 WRITE !?4,$JUSTIFY(RMPRLIN,2),?9,$QSUBSCRIPT(RMPRGBL,5)
+10 SET RMPRA(RMPRLIN)=$QSUBSCRIPT(RMPRGBL,6)
+11 IF RMPRLIN'<RMPRMAX
GOTO LIKEB
+12 GOTO LIKEA
LIKEB IF RMPRLIN=0
GOTO LIKEX
+1 SET DIR(0)="NAO^1:"_RMPRLIN_": "
SET DIR("A")="CHOOSE 1-"_RMPRLIN_": "
+2 DO ^DIR
WRITE !
+3 IF $DATA(DTOUT)
SET RMPREXC="T"
GOTO LIKEX
+4 IF $DATA(DIROUT)
SET RMPREXC="P"
GOTO LIKEX
+5 IF X=""
SET RMPREXC=""
GOTO LIKEX
+6 IF X["^"!$DATA(DUOUT)
SET RMPREXC="^"
GOTO LIKEX
+7 KILL RMPR11
+8 SET RMPR11("IEN")=RMPRA(X)
SET RMPRERR=$$GET^RMPRPIX1(.RMPR11)
LIKEX QUIT
+1 ;
LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
+1 if '$GET(RMF)!(X=" ")
QUIT
+2 SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 KILL RX
+4 IF $DATA(^RMPR(661.7,"XSHIDS",RMPR("STA"),X))
SET RX=1
+5 IF '$GET(RX)
IF $DATA(^RMPR(661.1,"B",X))
DO EN^DDIOL("*** Only PSAS HCPCS in PIP can be ordered. Please verify your Location and PSAS HCPCS!!","","!!")
+6 KILL RX
+7 QUIT
+8 ;
EXIT ;MAIN EXIT POINT
+1 NEW RMPRSITE,RMPR
DO KILL^XUSCLEAN
+2 QUIT
