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

RMPRPIYO.m

Go to the documentation of this file. 
  1. RMPRPIYO ;HIN/RVD-PROS INVENTORY ORDER/RE-ORDER ;5/7/01
  1.  ;;3.0;PROSTHETICS;**61**;Feb 09, 1996
  1.  D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
  1.  S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
  1.  ;
  1.  W @IOF
  1.  ;ask for location
  1.  W !!,"Ordering ITEM from Supply or Vendor....",!
  1.  ;
  1. HCPC ;ask for HCPCS
  1.  S RMF=1
  1.  K DTOUT,DUOUT,DIC
  1.  S DIC("A")="Select HCPCS to ORDER: "
  1.  ;
  1.  S DIC="^RMPR(661.11,",DIC(0)="AEMNQ"
  1.  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""))"
  1.  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)"
  1.  W ! D ^DIC I $D(DUOUT)!$D(DTOUT)!(Y<0) G EXIT
  1.  S RMHCPC=$P(^RMPR(661.11,+Y,0),U,1)
  1.  S RMIDA=$P(^RMPR(661.11,+Y,0),U,2)
  1.  S RMHCDA=$O(^RMPR(661.1,"B",RMHCPC,0))
  1.  S RMPR11("HCPCS")=RMHCPC
  1.  S RMPR11("ITEM")=RMIDA
  1.  S RMPR11("STATION")=RMPR("STA")
  1.  ;
  1. VEN ;order item from vendor.
  1.  K DIR,Y S DIR(0)="661.41,4",DIR("A")="Enter Vendor" D ^DIR
  1.  I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G HCPC
  1.  I X="" W $C(7),!,"Enter Vendor from the Vendor file.." G VEN
  1.  S RMVEN=+Y K DIR,Y
  1.  ;
  1.  ;
  1. ORDER ;order QUANTITY from vendor or supply.
  1.  K DIR,Y S DIR(0)="661.41,7",DIR("A")="Quantity to Order" D ^DIR
  1.  I $D(DUOUT)!$D(DTOUT) W !,"*** Item was not ordered...." H 1 G HCPC
  1.  I X="" W $C(7),!,"Enter quantity 1 to 99999.." G ORDER
  1.  S (RMPR6("QUANTITY"),RMORDER)=Y K DIR,Y
  1.  ;
  1. COM ;comments
  1.  K DIR,Y S DIR(0)="661.41,9",DIR("A")="Enter Comment" D ^DIR
  1.  I $D(DUOUT)!$D(DTOUT) G HCPC
  1.  S (RMPR6("COMMENT"),RMCOM)=Y
  1. SET6 ;set-up 661.6 data
  1.  S RMPR6("VENDOR")=$G(RMVEN)
  1.  S RMPR6("TRAN TYPE")=2
  1.  S RMPR6("LOCATION")=""
  1.  S RMPR6("USER")=$G(DUZ)
  1.  S RMPR6("VALUE")=""
  1. UP6 ;create file 661.6
  1.  S RMERR=$$CRE^RMPRPIX6(.RMPR6,.RMPR11)
  1.  I $G(RMERR) W !,"*** Error in file 661.6 update!!!",! H 2 G HCPC
  1. UPD ;update file 661.41
  1.  ;
  1.  ;D UPDATE^DIE("","RMDAT","","RMERR")
  1.  ;call API for 661.41
  1.  L +^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
  1.  K RMERR,RMERROR
  1.  S DIE="^RMPR(661.41,"
  1.  S RMDAT(661.41,"+1,",.01)=DT
  1.  S RMDAT(661.41,"+1,",1)=RMPR11("ITEM")
  1.  S RMDAT(661.41,"+1,",2)=RMPR("STA")
  1.  S RMDAT(661.41,"+1,",4)=RMVEN
  1.  S RMDAT(661.41,"+1,",5)=RMPR11("HCPCS")
  1.  S RMDAT(661.41,"+1,",7)=RMORDER
  1.  S RMDAT(661.41,"+1,",9)=RMCOM
  1.  S RMDAT(661.41,"+1,",10)="O"
  1.  D UPDATE^DIE("","RMDAT","","RMERR") I $D(RMERR) S RMERROR=1
  1.  L -^RMPR(661.41,"ASSHID",RMPR("STA"),"O",RMPR11("HCPCS"),RMPR11("ITEM"))
  1.  I $G(RMERROR) W !,"*** Error in file 661.41 update!!!",!
  1.  I '$G(RMERROR) W !,"*** Item was ordered...."
  1.  H 1 G HCPC
  1.  ;
  1.  ; Prompt if adding a new HCPCS Item
  1. OKADD(RMPR11,RMPRYN,RMPREXC) ;
  1.  N DIR,X,Y,DUOUT,DTOUT,DIROUT,DIRUT
  1.  S RMPREXC="",DIR(0)="Y"
  1.  S DIR("A")="Are you adding '"_RMPR11("DESCRIPTION")_"' as a new ITEM for this HCPCS"
  1.  D ^DIR
  1.  I $D(DTOUT) S RMPREXC="T" G ADDNMX
  1.  I $D(DIROUT) S RMPREXC="P" G ADDNMX
  1.  I X=""!(X["^") S RMPREXC="^" G ADDNMX
  1.  S RMPRYN="N" S:Y RMPRYN="Y"
  1.  S RMPREXC=""
  1. ADDNMX Q
  1.  ;
  1. LIKE(RMPRSTN,RMPRHCPC,RMPRTXT,RMPREXC,RMPR11) ;
  1.  N RMPRMAX,RMPRLIN,RMPRGBL,DIR,X,Y,DA,DTOUT,DIROUT,DIRUT,DUOUT,RMPRA
  1.  N RMPRERR,RMPRN
  1.  S RMPREXC="",RMPRMAX=19
  1.  S RMPRGBL="^RMPR(661.11,"_"""ASHD"","_RMPRSTN_","""_RMPRHCPC_""","""_RMPRTXT_""")"
  1.  I $D(^RMPR(661.11,"ASHI",RMPRSTN,RMPRHCPC,RMPRTXT)) D  G LIKEA
  1.  . S RMPRA(1)=$O(^RMPR(661.11,"ASHI",RMPR("STA"),RMPRHCPC,RMPRTXT,""))
  1.  . W !?5,1,?9,$P(^RMPR(661.11,RMPRA(1),0),"^",2)
  1.  . Q
  1. LIKEA1 K RMPRA S RMPRLIN=0
  1. LIKEA S RMPRGBL=$Q(@RMPRGBL)
  1.  I '$D(RMPRLIN) S RMPRLIN=0
  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)'=RMPR("STA") G LIKEB
  1.  I $QS(RMPRGBL,4)'=RMPRHCPC G LIKEB
  1.  I $E($QS(RMPRGBL,5),1,$L(RMPRTXT))'=RMPRTXT G LIKEB
  1.  S RMPRLIN=RMPRLIN+1
  1.  W !?4,$J(RMPRLIN,2),?9,$QS(RMPRGBL,5)
  1.  S RMPRA(RMPRLIN)=$QS(RMPRGBL,6)
  1.  I RMPRLIN'<RMPRMAX G LIKEB
  1.  G LIKEA
  1. LIKEB I RMPRLIN=0 G LIKEX
  1.  S DIR(0)="NAO^1:"_RMPRLIN_": ",DIR("A")="CHOOSE 1-"_RMPRLIN_": "
  1.  D ^DIR 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 LIKEX
  1.  I X["^"!$D(DUOUT) S RMPREXC="^" G LIKEX
  1.  K RMPR11
  1.  S RMPR11("IEN")=RMPRA(X),RMPRERR=$$GET^RMPRPIX1(.RMPR11)
  1. LIKEX Q
  1.  ;
  1. LKP ;print a message if PSAS HCPCS not in PIP or invalid HCPCS.
  1.  Q:'$G(RMF)!(X=" ")
  1.  S X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1.  K RX
  1.  I $D(^RMPR(661.7,"XSHIDS",RMPR("STA"),X)) S RX=1
  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!!","","!!")
  1.  K RX
  1.  Q
  1.  ;
  1. EXIT ;MAIN EXIT POINT
  1.  N RMPRSITE,RMPR D KILL^XUSCLEAN
  1.  Q