RMPOVDC ;HINCIO/RVD - HOME OXYGEN VENDOR/HCPCS/FCP UPDATE ;11/03/00
;;3.0;PROSTHETICS;**56**;Feb 09, 1996
;
Q
EXIT N RMPR,RMPRSITE
K RQUIT,RMPOXITE
D KILL^XUSCLEAN
Q
;
START ;
D KEY() G:$G(RQUIT) EXIT
D SITE G:'$D(RMPOXITE) EXIT
K DIR S RMCNT=0
S DIR(0)="S^1:Update VENDOR;2:Update HCPCS;3:Update FCP;4:Update ITEM;5:Update UNIT COST"
S DIR("A")="Type of Update",DIR("B")="Update VENDOR" D ^DIR
Q:$D(DIRUT)!($D(DTOUT))
S RMPRCHA=$S(Y=1:"VEN",Y=2:"HCPCS",Y=3:"FCP",Y=4:"ITEM",Y=5:"COST",1:"RQUIT")
D @RMPRCHA
D EXIT
Q
;
VEN ;change vendor utility
N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,Y,X
K RMOLDVEN,RMNEWVEN
S DIC("A")="Enter Existing Vendor to UPdate: ",DA(1)=RMPOXITE,RMCNT=0
S DIC(0)="AEMQZ",DIC="^RMPR(669.9,"_DA(1)_",""RMPOVDR""," D ^DIC
Q:Y<0!($$RQUIT) S RMOLDVEN=+Y,DIC("S")="I +Y'=RMOLDVEN"
S DIC("A")="Enter NEW Vendor: "
D ^DIC Q:Y<0!($$RQUIT) S RMNEWVEN=+Y
K DIC,DA
;change vendor in file #665
S DIE="^RMPR(665,"
W:$D(^PRC(440,RMOLDVEN,0)) !!,"Updating HO template for vendor ",$P(^PRC(440,RMOLDVEN,0),U,1)," to "
W:$D(^PRC(440,RMNEWVEN,0)) $P(^PRC(440,RMNEWVEN,0),U,1)," ...."
F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
.F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMVEN=$P(RIT,U,2) I RMVEN=RMOLDVEN D
..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
..S DA=RJ,DR="1///^S X=RMNEWVEN" D ^DIE S RMCNT=RMCNT+1
W !,"** ",RMCNT," Records updated **"
Q
;
FCP ;change FCP utility.
N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMFCP,RMODES,RMNDES
N RMOLDFCP
S DIC("A")="Enter Existing Fund Control Point to Update: ",DA(1)=RMPOXITE
S DIC(0)="AEMQZ",DIC="^RMPR(669.9,"_DA(1)_",""RMPOFCP""," D ^DIC
Q:Y<0!($$RQUIT) S RMOLDFCP=+Y,RMODES=$P(Y,U,2)
S DIC("A")="Enter NEW Fund Control Point: "
S DIC("S")="I +Y'=RMOLDFCP"
D ^DIC Q:Y<0!($$RQUIT) S RMNDES=$P(Y,U,2)
K DIC,DA
;change FCP in file #665
W !!,"Updating HO template for FCP ",RMODES," to ",RMNDES,"......"
F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
.F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMFCP=$P(RIT,U,6) I RMFCP=RMODES D
..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
..S DA=RJ,DR="5////^S X=RMNDES" D ^DIE S RMCNT=RMCNT+1
W !,"** ",RMCNT," Records updated **"
Q
;
HCPCS ; change HCPCS utility.
N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMODES,RMNDES
N RMOLDHCP,RMNEWHCP,RMHCPC
S DIC("A")="Enter Existing HCPCS to Update: "
S DIC(0)="AEMQZ",DIC="^RMPR(661.1," D ^DIC
Q:Y<0!($$RQUIT) S RMOLDHCP=+Y,RMODES=$P(^RMPR(661.1,+Y,0),U,1)
S DIC("S")="I +Y'=RMOLDHCP"
S DIC("A")="Enter NEW HCPCS: "
D ^DIC Q:Y<0!($$RQUIT) S RMNEWHCP=+Y,RMNDES=$P(^RMPR(661.1,+Y,0),U,1)
K DIC,DA
;change HCPCS in file #665
W !!,"Updating HO template for HCPCS ",RMODES," to ",RMNDES,"......"
F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
.F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMHCPC=$P(RIT,U,7) I RMHCPC=RMOLDHCP D
..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
..S DA=RJ,DR="6////^S X=RMNEWHCP" D ^DIE S RMCNT=RMCNT+1
W !,"** ",RMCNT," Records updated **"
Q
;
ITEM ; change ITEM utility.
N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMITEM
N RMOITEM,RMNITEM
S DIC("A")="Enter Existing ITEM to Update: "
S DIC(0)="AEMQZ",DIC="^RMPR(661," D ^DIC
Q:Y<0!($$RQUIT) S RMOITEM=+Y,RMOIFIT=$P($G(^RMPR(661,+Y,0)),U,1)
S DIC("A")="Enter NEW ITEM: " K X,Y
D ^DIC Q:Y<0!($$RQUIT)
S RMNITEM=+Y,RMNIFIT=$P($G(^RMPR(661,+Y,0)),U,1)
K DIC,DA
;change ITEM in file #665
W !!,"Updating HO template for item ",$P($G(^PRC(441,RMOIFIT,0)),U,2)," to ",$P($G(^PRC(441,RMNIFIT,0)),U,2),"......"
F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
.F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMITEM=$P(RIT,U,1) I RMITEM=RMOITEM D
..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
..S DA=RJ,DR=".01////^S X=RMNITEM" D ^DIE S RMCNT=RMCNT+1
W !,"** ",RMCNT," Records updated **"
Q
;
COST ; change UNIT COST utility.
N RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMITDES,RMIT,RMITEM,RMIFIT
N RMNCOST
S DIC("A")="Enter an ITEM for UNIT COST Update: "
S DIC(0)="AEMQZ",DIC="^RMPR(661," D ^DIC Q:Y<0!($$RQUIT)
S RMIT=+Y,RMIFIT=$P($G(^RMPR(661,RMIT,0)),U,1)
I $G(RMIFIT),$D(^PRC(441,RMIFIT,0)) S RMITDES=$P(^PRC(441,RMIFIT,0),U,2)
S DIR("A")="Enter new UNIT COST for item "_RMITDES
S DIR(0)="667.3,3" D ^DIR Q:Y<0!($$RQUIT) S RMNCOST=+Y
K DIC,DA
;change HCPCS in file #665
W !!,"Updating HO template for unit cost of item "_RMITDES_" to ",$J(RMNCOST,0,2),"......"
F RI=0:0 S RI=$O(^RMPR(665,RI)) Q:RI'>0!$G(RQUIT) S RD=$G(^RMPR(665,RI,"RMPOA")),RMSTA=$P(RD,U,7),RMIDT=$P(RD,U,3) I RMSTA=RMPOXITE,((RMIDT="")!(RMIDT>DT)) D
.F RJ=0:0 S RJ=$O(^RMPR(665,RI,"RMPOC",RJ)) Q:RJ'>0!$G(RQUIT) S RIT=$G(^RMPR(665,RI,"RMPOC",RJ,0)),RMITEM=$P(RIT,U,1) I RMITEM=RMIT D
..S DA(1)=RI,DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
..S DA=RJ,DR="3////^S X=RMNCOST" D ^DIE S RMCNT=RMCNT+1
W !,"** ",RMCNT," Records updated **"
Q
;
LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F
S C=$G(C," ") ;DEFAULT PAD CHAR IS SPACE
S $P(S,C,W-$L(S)+$L(S,C))=""
Q S
;
SITE ; get Home Oxygen site
K DIC,DIE,DA,DR,DD,RMPOXITE
S DIC="^RMPR(669.9,",DIC(0)="QEAMLZ",DIC("A")="Select SITE: "
D ^DIC Q:Y<0!($$RQUIT)
S RMPOXITE=+Y
Q
;
KEY() ;user must have the RMPRSUPERVISOR key in order to change
;vendor, HCPCS, FCP and items.
N RMKEY
S RMKEY=$O(^DIC(19.1,"B","RMPRSUPERVISOR",0))
I '$D(^VA(200,DUZ,51,RMKEY)) D Q
. W !!,"You do not hold a RMPSUPERVISOR key !!"
. S RQUIT=1
Q
;
RQUIT() S RQUIT=$D(DTOUT)!$D(DUOUT)!$D(DIRUT) Q RQUIT
EQUIT() S RQUIT=$D(DTOUT)!$D(Y) Q RQUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPOVDC 6331 printed Sep 23, 2025@20:07:44 Page 2
RMPOVDC ;HINCIO/RVD - HOME OXYGEN VENDOR/HCPCS/FCP UPDATE ;11/03/00
+1 ;;3.0;PROSTHETICS;**56**;Feb 09, 1996
+2 ;
+3 QUIT
EXIT NEW RMPR,RMPRSITE
+1 KILL RQUIT,RMPOXITE
+2 DO KILL^XUSCLEAN
+3 QUIT
+4 ;
START ;
+1 DO KEY()
if $GET(RQUIT)
GOTO EXIT
+2 DO SITE
if '$DATA(RMPOXITE)
GOTO EXIT
+3 KILL DIR
SET RMCNT=0
+4 SET DIR(0)="S^1:Update VENDOR;2:Update HCPCS;3:Update FCP;4:Update ITEM;5:Update UNIT COST"
+5 SET DIR("A")="Type of Update"
SET DIR("B")="Update VENDOR"
DO ^DIR
+6 if $DATA(DIRUT)!($DATA(DTOUT))
QUIT
+7 SET RMPRCHA=$SELECT(Y=1:"VEN",Y=2:"HCPCS",Y=3:"FCP",Y=4:"ITEM",Y=5:"COST",1:"RQUIT")
+8 DO @RMPRCHA
+9 DO EXIT
+10 QUIT
+11 ;
VEN ;change vendor utility
+1 NEW RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,Y,X
+2 KILL RMOLDVEN,RMNEWVEN
+3 SET DIC("A")="Enter Existing Vendor to UPdate: "
SET DA(1)=RMPOXITE
SET RMCNT=0
+4 SET DIC(0)="AEMQZ"
SET DIC="^RMPR(669.9,"_DA(1)_",""RMPOVDR"","
DO ^DIC
+5 if Y<0!($$RQUIT)
QUIT
SET RMOLDVEN=+Y
SET DIC("S")="I +Y'=RMOLDVEN"
+6 SET DIC("A")="Enter NEW Vendor: "
+7 DO ^DIC
if Y<0!($$RQUIT)
QUIT
SET RMNEWVEN=+Y
+8 KILL DIC,DA
+9 ;change vendor in file #665
+10 SET DIE="^RMPR(665,"
+11 if $DATA(^PRC(440,RMOLDVEN,0))
WRITE !!,"Updating HO template for vendor ",$PIECE(^PRC(440,RMOLDVEN,0),U,1)," to "
+12 if $DATA(^PRC(440,RMNEWVEN,0))
WRITE $PIECE(^PRC(440,RMNEWVEN,0),U,1)," ...."
+13 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RI))
if RI'>0!$GET(RQUIT)
QUIT
SET RD=$GET(^RMPR(665,RI,"RMPOA"))
SET RMSTA=$PIECE(RD,U,7)
SET RMIDT=$PIECE(RD,U,3)
IF RMSTA=RMPOXITE
IF ((RMIDT="")!(RMIDT>DT))
Begin DoDot:1
+14 FOR RJ=0:0
SET RJ=$ORDER(^RMPR(665,RI,"RMPOC",RJ))
if RJ'>0!$GET(RQUIT)
QUIT
SET RIT=$GET(^RMPR(665,RI,"RMPOC",RJ,0))
SET RMVEN=$PIECE(RIT,U,2)
IF RMVEN=RMOLDVEN
Begin DoDot:2
+15 SET DA(1)=RI
SET DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
+16 SET DA=RJ
SET DR="1///^S X=RMNEWVEN"
DO ^DIE
SET RMCNT=RMCNT+1
End DoDot:2
End DoDot:1
+17 WRITE !,"** ",RMCNT," Records updated **"
+18 QUIT
+19 ;
FCP ;change FCP utility.
+1 NEW RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMFCP,RMODES,RMNDES
+2 NEW RMOLDFCP
+3 SET DIC("A")="Enter Existing Fund Control Point to Update: "
SET DA(1)=RMPOXITE
+4 SET DIC(0)="AEMQZ"
SET DIC="^RMPR(669.9,"_DA(1)_",""RMPOFCP"","
DO ^DIC
+5 if Y<0!($$RQUIT)
QUIT
SET RMOLDFCP=+Y
SET RMODES=$PIECE(Y,U,2)
+6 SET DIC("A")="Enter NEW Fund Control Point: "
+7 SET DIC("S")="I +Y'=RMOLDFCP"
+8 DO ^DIC
if Y<0!($$RQUIT)
QUIT
SET RMNDES=$PIECE(Y,U,2)
+9 KILL DIC,DA
+10 ;change FCP in file #665
+11 WRITE !!,"Updating HO template for FCP ",RMODES," to ",RMNDES,"......"
+12 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RI))
if RI'>0!$GET(RQUIT)
QUIT
SET RD=$GET(^RMPR(665,RI,"RMPOA"))
SET RMSTA=$PIECE(RD,U,7)
SET RMIDT=$PIECE(RD,U,3)
IF RMSTA=RMPOXITE
IF ((RMIDT="")!(RMIDT>DT))
Begin DoDot:1
+13 FOR RJ=0:0
SET RJ=$ORDER(^RMPR(665,RI,"RMPOC",RJ))
if RJ'>0!$GET(RQUIT)
QUIT
SET RIT=$GET(^RMPR(665,RI,"RMPOC",RJ,0))
SET RMFCP=$PIECE(RIT,U,6)
IF RMFCP=RMODES
Begin DoDot:2
+14 SET DA(1)=RI
SET DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
+15 SET DA=RJ
SET DR="5////^S X=RMNDES"
DO ^DIE
SET RMCNT=RMCNT+1
End DoDot:2
End DoDot:1
+16 WRITE !,"** ",RMCNT," Records updated **"
+17 QUIT
+18 ;
HCPCS ; change HCPCS utility.
+1 NEW RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMODES,RMNDES
+2 NEW RMOLDHCP,RMNEWHCP,RMHCPC
+3 SET DIC("A")="Enter Existing HCPCS to Update: "
+4 SET DIC(0)="AEMQZ"
SET DIC="^RMPR(661.1,"
DO ^DIC
+5 if Y<0!($$RQUIT)
QUIT
SET RMOLDHCP=+Y
SET RMODES=$PIECE(^RMPR(661.1,+Y,0),U,1)
+6 SET DIC("S")="I +Y'=RMOLDHCP"
+7 SET DIC("A")="Enter NEW HCPCS: "
+8 DO ^DIC
if Y<0!($$RQUIT)
QUIT
SET RMNEWHCP=+Y
SET RMNDES=$PIECE(^RMPR(661.1,+Y,0),U,1)
+9 KILL DIC,DA
+10 ;change HCPCS in file #665
+11 WRITE !!,"Updating HO template for HCPCS ",RMODES," to ",RMNDES,"......"
+12 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RI))
if RI'>0!$GET(RQUIT)
QUIT
SET RD=$GET(^RMPR(665,RI,"RMPOA"))
SET RMSTA=$PIECE(RD,U,7)
SET RMIDT=$PIECE(RD,U,3)
IF RMSTA=RMPOXITE
IF ((RMIDT="")!(RMIDT>DT))
Begin DoDot:1
+13 FOR RJ=0:0
SET RJ=$ORDER(^RMPR(665,RI,"RMPOC",RJ))
if RJ'>0!$GET(RQUIT)
QUIT
SET RIT=$GET(^RMPR(665,RI,"RMPOC",RJ,0))
SET RMHCPC=$PIECE(RIT,U,7)
IF RMHCPC=RMOLDHCP
Begin DoDot:2
+14 SET DA(1)=RI
SET DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
+15 SET DA=RJ
SET DR="6////^S X=RMNEWHCP"
DO ^DIE
SET RMCNT=RMCNT+1
End DoDot:2
End DoDot:1
+16 WRITE !,"** ",RMCNT," Records updated **"
+17 QUIT
+18 ;
ITEM ; change ITEM utility.
+1 NEW RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMITEM
+2 NEW RMOITEM,RMNITEM
+3 SET DIC("A")="Enter Existing ITEM to Update: "
+4 SET DIC(0)="AEMQZ"
SET DIC="^RMPR(661,"
DO ^DIC
+5 if Y<0!($$RQUIT)
QUIT
SET RMOITEM=+Y
SET RMOIFIT=$PIECE($GET(^RMPR(661,+Y,0)),U,1)
+6 SET DIC("A")="Enter NEW ITEM: "
KILL X,Y
+7 DO ^DIC
if Y<0!($$RQUIT)
QUIT
+8 SET RMNITEM=+Y
SET RMNIFIT=$PIECE($GET(^RMPR(661,+Y,0)),U,1)
+9 KILL DIC,DA
+10 ;change ITEM in file #665
+11 WRITE !!,"Updating HO template for item ",$PIECE($GET(^PRC(441,RMOIFIT,0)),U,2)," to ",$PIECE($GET(^PRC(441,RMNIFIT,0)),U,2),"......"
+12 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RI))
if RI'>0!$GET(RQUIT)
QUIT
SET RD=$GET(^RMPR(665,RI,"RMPOA"))
SET RMSTA=$PIECE(RD,U,7)
SET RMIDT=$PIECE(RD,U,3)
IF RMSTA=RMPOXITE
IF ((RMIDT="")!(RMIDT>DT))
Begin DoDot:1
+13 FOR RJ=0:0
SET RJ=$ORDER(^RMPR(665,RI,"RMPOC",RJ))
if RJ'>0!$GET(RQUIT)
QUIT
SET RIT=$GET(^RMPR(665,RI,"RMPOC",RJ,0))
SET RMITEM=$PIECE(RIT,U,1)
IF RMITEM=RMOITEM
Begin DoDot:2
+14 SET DA(1)=RI
SET DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
+15 SET DA=RJ
SET DR=".01////^S X=RMNITEM"
DO ^DIE
SET RMCNT=RMCNT+1
End DoDot:2
End DoDot:1
+16 WRITE !,"** ",RMCNT," Records updated **"
+17 QUIT
+18 ;
COST ; change UNIT COST utility.
+1 NEW RI,RJ,RD,RIT,RMSTA,DIE,DA,DIC,DIR,Y,X,RMITDES,RMIT,RMITEM,RMIFIT
+2 NEW RMNCOST
+3 SET DIC("A")="Enter an ITEM for UNIT COST Update: "
+4 SET DIC(0)="AEMQZ"
SET DIC="^RMPR(661,"
DO ^DIC
if Y<0!($$RQUIT)
QUIT
+5 SET RMIT=+Y
SET RMIFIT=$PIECE($GET(^RMPR(661,RMIT,0)),U,1)
+6 IF $GET(RMIFIT)
IF $DATA(^PRC(441,RMIFIT,0))
SET RMITDES=$PIECE(^PRC(441,RMIFIT,0),U,2)
+7 SET DIR("A")="Enter new UNIT COST for item "_RMITDES
+8 SET DIR(0)="667.3,3"
DO ^DIR
if Y<0!($$RQUIT)
QUIT
SET RMNCOST=+Y
+9 KILL DIC,DA
+10 ;change HCPCS in file #665
+11 WRITE !!,"Updating HO template for unit cost of item "_RMITDES_" to ",$JUSTIFY(RMNCOST,0,2),"......"
+12 FOR RI=0:0
SET RI=$ORDER(^RMPR(665,RI))
if RI'>0!$GET(RQUIT)
QUIT
SET RD=$GET(^RMPR(665,RI,"RMPOA"))
SET RMSTA=$PIECE(RD,U,7)
SET RMIDT=$PIECE(RD,U,3)
IF RMSTA=RMPOXITE
IF ((RMIDT="")!(RMIDT>DT))
Begin DoDot:1
+13 FOR RJ=0:0
SET RJ=$ORDER(^RMPR(665,RI,"RMPOC",RJ))
if RJ'>0!$GET(RQUIT)
QUIT
SET RIT=$GET(^RMPR(665,RI,"RMPOC",RJ,0))
SET RMITEM=$PIECE(RIT,U,1)
IF RMITEM=RMIT
Begin DoDot:2
+14 SET DA(1)=RI
SET DIE="^RMPR(665,"_DA(1)_","_"""RMPOC"""_","
+15 SET DA=RJ
SET DR="3////^S X=RMNCOST"
DO ^DIE
SET RMCNT=RMCNT+1
End DoDot:2
End DoDot:1
+16 WRITE !,"** ",RMCNT," Records updated **"
+17 QUIT
+18 ;
LJ(S,W,C) ; LEFT JUSTIFY S IN A FIELD W WIDE PADDING WITH CHAR F
+1 ;DEFAULT PAD CHAR IS SPACE
SET C=$GET(C," ")
+2 SET $PIECE(S,C,W-$LENGTH(S)+$LENGTH(S,C))=""
+3 QUIT S
+4 ;
SITE ; get Home Oxygen site
+1 KILL DIC,DIE,DA,DR,DD,RMPOXITE
+2 SET DIC="^RMPR(669.9,"
SET DIC(0)="QEAMLZ"
SET DIC("A")="Select SITE: "
+3 DO ^DIC
if Y<0!($$RQUIT)
QUIT
+4 SET RMPOXITE=+Y
+5 QUIT
+6 ;
KEY() ;user must have the RMPRSUPERVISOR key in order to change
+1 ;vendor, HCPCS, FCP and items.
+2 NEW RMKEY
+3 SET RMKEY=$ORDER(^DIC(19.1,"B","RMPRSUPERVISOR",0))
+4 IF '$DATA(^VA(200,DUZ,51,RMKEY))
Begin DoDot:1
+5 WRITE !!,"You do not hold a RMPSUPERVISOR key !!"
+6 SET RQUIT=1
End DoDot:1
QUIT
+7 QUIT
+8 ;
RQUIT() SET RQUIT=$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
QUIT RQUIT
EQUIT() SET RQUIT=$DATA(DTOUT)!$DATA(Y)
QUIT RQUIT
