- RMPR5NEE ;HIN/RVD-PROS INVENTORY EDIT UTILITY ;2/11/98
- ;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
- D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q
- ;S RMKEY=$O(^DIC(19.1,"B","RMPRMANAGER",0))
- S X="NOW" D ^%DT
- LOC ;ask for Location.
- W @IOF,!!,"Editing an Inventory Item in a Location.....",! K DTOUT,DUOUT,DIC("B")
- S DZ="??",D="B",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
- S DIC="^RMPR(661.3,",DIC(0)="AEQM"
- S D="B",DIC("A")="Enter Pros Location: " D MIX^DIC1
- G:$D(DTOUT)!$D(DUOUT)!(Y'>0) EXIT S (DA,RMLODA)=+Y
- L +^RMPR(661.3,RMLODA):2
- I '$T W !,"Record in use. Try again later..." G LOC
- S RML=$P(^RMPR(661.3,RMLODA,0),U,1)
- S DIE=DIC,DR=".01" D ^DIE K DIE,DR
- G:$D(Y)!'$D(^RMPR(661.3,RMLODA,0)) LOC
- S RMLOC=$P(^RMPR(661.3,RMLODA,0),U,1),DIK=DIC W:RML'=RMLOC !,"Location has been edited from '"_RML_"' to '"_RMLOC_"' !!!"
- I $P(^RMPR(661.3,RMLODA,0),U,3)="" S $P(^(0),U,3)=RMPR("STA") D IX1^DIK
- L -^RMPR(661.3,RMLODA)
- ;
- LIST ;list current HCPCS @ this Location
- K DIC("S"),RMR,RMX S DIC("A")="Select HCPCS to EDIT: ",DA(1)=RMLODA
- S DIC="^RMPR(661.3,"_DA(1)_",1,",DIC(0)="AEMQ",DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?15,$P(^RMPR(661.1,RZ,0),U,2)"
- D ^DIC I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 1 G LOC
- S RMDAHC=$P($G(^RMPR(661.3,RMLODA,1,+Y,0)),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1),RMHCDA=+Y
- S DA(2)=RMLODA,DA(1)=RMHCDA K DIC
- ITEM ;ask for PSAS Item to to edit.
- S DIC("A")="Enter PSAS Item to Edit: ",DIC(0)="AEMNQ"
- S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
- D ^DIC
- G:Y'>0!$D(DTOUT)!$D(DUOUT) LOC
- L +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
- I '$T W !,"Record in use. Try again later..." G LOC
- ;
- ;for item in 661.3
- S (DA,RMITDA)=+Y,RDIC3=DIC K DIC("B")
- S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),RMIT=$P(RM3,U,1),RMDAIT=$P(RMIT,"-",2)
- S RMITEM=$P(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
- S RMQU=$P(RM3,U,2),RMCO=$P(RM3,U,3) S:'RMQU RMQU=0 S:'RMCO RMCO=0
- ;
- UPD ;updates item in 661.3
- S (RMAVA,RMQUD,RMCOD)=0,DIE=RDIC3
- S DR="29;22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
- D ^DIE
- S RM3A=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
- S RMQUA=$P(RM3A,U,2),RMCOA=$P(RM3A,U,3),RMAVA=$P(RM3A,U,10),RMSO=$P(RM3A,U,9)
- I RMQUA=RMQU,RMCOA=RMCO G LOC
- I (RMSO="C")&(RMCOA<.0001) G LIST
- I RMSO="C" S:RMAVA<1&RMQUA>0 RMAVA=RMCOA/RMQUA
- I RMCO'=RMCOA S RMCOD=RMCOA-RMCO
- I RMQU'=RMQUA S RMQUD=RMQUA-RMQU
- I RMQUD,'RMCOD S RMCOA=RMAVA*RMQUA
- I 'RMQUD,RMCOD S:RMQUA>0 RMAVA=RMCOA/RMQUA
- I RMQUD,RMCOD S:RMQUA>0 RMAVA=RMCOA/RMQUA
- S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
- S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,8)=RMITEM
- S $P(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$J(RMAVA,0,2)
- ;
- STAT ;create an item statistics for this event.
- G:RMQU=RMQUA&(RMCO=RMCOA) LIST
- D BAL^RMPR5NU1
- L -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
- K DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN
- G:$D(DTOUT)!(Y'>0) LIST S DA=+Y
- S RMMESF="Edited by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": ("
- S RMMESF=RMMESF_$S(RMQUD>0:"+"_RMQUD_")",1:RMQUD_")")
- S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQUD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2) S DIK=DIC D IX1^DIK
- W !!,"** Item ",RMITEM," was ",RMMESF," @ Location ",RMLOC
- H 2 G LIST
- ;
- DEL ;delete a location
- S DIR(0)="Y",DIR("B")="N"
- W !,"This will DELETE all HCPCS and ITEMS under this LOCATION..."
- S DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "
- D ^DIR I $D(DTOUT)!$D(DUOUT) S RMX=RMR("B") S:Y="^" RMEXIT=1 Q
- L +^RMPR(661.3,RMLODA):2
- I '$T W !,"Record in use. Try again later..." S RMEXIT=1 Q
- I Y>0 S DIK="^RMPR(661.3,",DA=RMLODA D ^DIK W:'$D(^RMPR(661.3,RMLODA,0)) !,"Location is deleted!!!!" H 2 K DIR,DIK,X
- Q
- ;
- EXIT ;MAIN EXIT POINT
- N RMPR,RMPRSITE D KILL^XUSCLEAN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NEE 3872 printed Apr 23, 2025@18:47:45 Page 2
- RMPR5NEE ;HIN/RVD-PROS INVENTORY EDIT UTILITY ;2/11/98
- +1 ;;3.0;PROSTHETICS;**33,37**;Feb 09, 1996
- +2 DO DIV4^RMPRSIT
- IF $DATA(Y)
- IF (Y<0)
- KILL DIC("B")
- QUIT
- +3 ;S RMKEY=$O(^DIC(19.1,"B","RMPRMANAGER",0))
- +4 SET X="NOW"
- DO ^%DT
- LOC ;ask for Location.
- +1 WRITE @IOF,!!,"Editing an Inventory Item in a Location.....",!
- KILL DTOUT,DUOUT,DIC("B")
- +2 SET DZ="??"
- SET D="B"
- SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
- +3 SET DIC="^RMPR(661.3,"
- SET DIC(0)="AEQM"
- +4 SET D="B"
- SET DIC("A")="Enter Pros Location: "
- DO MIX^DIC1
- +5 if $DATA(DTOUT)!$DATA(DUOUT)!(Y'>0)
- GOTO EXIT
- SET (DA,RMLODA)=+Y
- +6 LOCK +^RMPR(661.3,RMLODA):2
- +7 IF '$TEST
- WRITE !,"Record in use. Try again later..."
- GOTO LOC
- +8 SET RML=$PIECE(^RMPR(661.3,RMLODA,0),U,1)
- +9 SET DIE=DIC
- SET DR=".01"
- DO ^DIE
- KILL DIE,DR
- +10 if $DATA(Y)!'$DATA(^RMPR(661.3,RMLODA,0))
- GOTO LOC
- +11 SET RMLOC=$PIECE(^RMPR(661.3,RMLODA,0),U,1)
- SET DIK=DIC
- if RML'=RMLOC
- WRITE !,"Location has been edited from '"_RML_"' to '"_RMLOC_"' !!!"
- +12 IF $PIECE(^RMPR(661.3,RMLODA,0),U,3)=""
- SET $PIECE(^(0),U,3)=RMPR("STA")
- DO IX1^DIK
- +13 LOCK -^RMPR(661.3,RMLODA)
- +14 ;
- LIST ;list current HCPCS @ this Location
- +1 KILL DIC("S"),RMR,RMX
- SET DIC("A")="Select HCPCS to EDIT: "
- SET DA(1)=RMLODA
- +2 SET DIC="^RMPR(661.3,"_DA(1)_",1,"
- SET DIC(0)="AEMQ"
- SET DIC("W")="S RZ=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1) I RZ W ?15,$P(^RMPR(661.1,RZ,0),U,2)"
- +3 DO ^DIC
- IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
- WRITE !,"** No HCPCS selected..."
- HANG 1
- GOTO LOC
- +4 SET RMDAHC=$PIECE($GET(^RMPR(661.3,RMLODA,1,+Y,0)),U,1)
- SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
- SET RMHCDA=+Y
- +5 SET DA(2)=RMLODA
- SET DA(1)=RMHCDA
- KILL DIC
- ITEM ;ask for PSAS Item to to edit.
- +1 SET DIC("A")="Enter PSAS Item to Edit: "
- SET DIC(0)="AEMNQ"
- +2 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
- +3 DO ^DIC
- +4 if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO LOC
- +5 LOCK +^RMPR(661.3,RMLODA,1,RMHCDA,1,+Y):2
- +6 IF '$TEST
- WRITE !,"Record in use. Try again later..."
- GOTO LOC
- +7 ;
- +8 ;for item in 661.3
- +9 SET (DA,RMITDA)=+Y
- SET RDIC3=DIC
- KILL DIC("B")
- +10 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
- SET RMIT=$PIECE(RM3,U,1)
- SET RMDAIT=$PIECE(RMIT,"-",2)
- +11 SET RMITEM=$PIECE(^RMPR(661.1,RMDAHC,3,RMDAIT,0),U,1)
- +12 SET RMQU=$PIECE(RM3,U,2)
- SET RMCO=$PIECE(RM3,U,3)
- if 'RMQU
- SET RMQU=0
- if 'RMCO
- SET RMCO=0
- +13 ;
- UPD ;updates item in 661.3
- +1 SET (RMAVA,RMQUD,RMCOD)=0
- SET DIE=RDIC3
- +2 SET DR="29;22R;23R~TOTAL COST OF QUANTITY;24;25R;26;27"
- +3 DO ^DIE
- +4 SET RM3A=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
- +5 SET RMQUA=$PIECE(RM3A,U,2)
- SET RMCOA=$PIECE(RM3A,U,3)
- SET RMAVA=$PIECE(RM3A,U,10)
- SET RMSO=$PIECE(RM3A,U,9)
- +6 IF RMQUA=RMQU
- IF RMCOA=RMCO
- GOTO LOC
- +7 IF (RMSO="C")&(RMCOA<.0001)
- GOTO LIST
- +8 IF RMSO="C"
- if RMAVA<1&RMQUA>0
- SET RMAVA=RMCOA/RMQUA
- +9 IF RMCO'=RMCOA
- SET RMCOD=RMCOA-RMCO
- +10 IF RMQU'=RMQUA
- SET RMQUD=RMQUA-RMQU
- +11 IF RMQUD
- IF 'RMCOD
- SET RMCOA=RMAVA*RMQUA
- +12 IF 'RMQUD
- IF RMCOD
- if RMQUA>0
- SET RMAVA=RMCOA/RMQUA
- +13 IF RMQUD
- IF RMCOD
- if RMQUA>0
- SET RMAVA=RMCOA/RMQUA
- +14 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,3)=RMCOA
- +15 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,8)=RMITEM
- +16 SET $PIECE(^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0),U,10)=$JUSTIFY(RMAVA,0,2)
- +17 ;
- STAT ;create an item statistics for this event.
- +1 if RMQU=RMQUA&(RMCO=RMCOA)
- GOTO LIST
- +2 DO BAL^RMPR5NU1
- +3 LOCK -^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA)
- +4 KILL DD,DO
- SET DIC="^RMPR(661.2,"
- SET DIC(0)="L"
- SET X=DT
- SET DLAYGO=661.2
- DO FILE^DICN
- +5 if $DATA(DTOUT)!(Y'>0)
- GOTO LIST
- SET DA=+Y
- +6 SET RMMESF="Edited by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_": ("
- +7 SET RMMESF=RMMESF_$SELECT(RMQUD>0:"+"_RMQUD_")",1:RMQUD_")")
- +8 SET ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^"_RMQUD_"^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
- SET DIK=DIC
- DO IX1^DIK
- +9 WRITE !!,"** Item ",RMITEM," was ",RMMESF," @ Location ",RMLOC
- +10 HANG 2
- GOTO LIST
- +11 ;
- DEL ;delete a location
- +1 SET DIR(0)="Y"
- SET DIR("B")="N"
- +2 WRITE !,"This will DELETE all HCPCS and ITEMS under this LOCATION..."
- +3 SET DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "
- +4 DO ^DIR
- IF $DATA(DTOUT)!$DATA(DUOUT)
- SET RMX=RMR("B")
- if Y="^"
- SET RMEXIT=1
- QUIT
- +5 LOCK +^RMPR(661.3,RMLODA):2
- +6 IF '$TEST
- WRITE !,"Record in use. Try again later..."
- SET RMEXIT=1
- QUIT
- +7 IF Y>0
- SET DIK="^RMPR(661.3,"
- SET DA=RMLODA
- DO ^DIK
- if '$DATA(^RMPR(661.3,RMLODA,0))
- WRITE !,"Location is deleted!!!!"
- HANG 2
- KILL DIR,DIK,X
- +8 QUIT
- +9 ;
- EXIT ;MAIN EXIT POINT
- +1 NEW RMPR,RMPRSITE
- DO KILL^XUSCLEAN
- +2 QUIT
