- 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 Mar 13, 2025@21:36:22 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
