- RMPR5NRE ;HIN/RVD-PROS INVENTORY REMOVE 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 X="NOW" D ^%DT D DD^%DT S RMDAT=Y
- W @IOF
- ;
- LOC ;get location
- S RMFLG=0
- S DZ="??",D="B"
- K DTOUT,DUOUT,DIC("B"),DIC("S")
- S DIC="^RMPR(661.3,",DIC(0)="AEQM"
- S DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
- S DIC(0)="AEQM"
- ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
- S DIC("A")="Enter LOCATION: " D MIX^DIC1
- G:Y'>0!$D(DTOUT)!$D(DUOUT) EXIT S RMLODA=+Y
- S RMLOC=$P($G(^RMPR(661.3,+Y,0)),U,1)
- ;
- LIST ;list current HCPCS @ this Location
- K DTOUT,DUOUT,DIC("S"),DIR
- S DIC("A")="Select HCPCS to Remove: "
- S DA(1)=RMLODA,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)"
- S DIC="^RMPR(661.3,"_RMLODA_",1," D ^DIC
- I +Y'>0!$D(DTOUT)!$D(DUOUT) W !,"** No HCPCS selected..." H 2 G LOC
- S RMHCDA=+Y,RMDAHC=$P(^RMPR(661.3,RMLODA,1,+Y,0),U,1),RMHCPC=$P(^RMPR(661.1,RMDAHC,0),U,1)
- ;
- ITEM G:'RMHCDA LIST K DIC
- S DA(1)=RMHCDA,DA(2)=RMLODA,DZ="??",D="B"
- S DIC("A")="Enter Item to Remove: "
- S DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,",DIC(0)="AEMNQ"
- ;I $D(^RMPR(661.1,RMDAHC,3,"B")) D DQ^DICQ
- D ^DIC G:Y'>0!$D(DTOUT)!$D(DUOUT) LOC S RMITDA=+Y
- S RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
- S RMIT=$P(RM3,U,1),RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMSO=$P(RM3,U,9)
- S RMDAIT=$P(RMIT,"-",2)
- S RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0)
- S DIR("A")="Are you sure you want to DEACTIVATE/REMOVE this item (Y/N)"
- S DIR(0)="Y" D ^DIR G:$D(DTOUT)!(+Y=0)!$D(DUOUT) LOC
- S DA=RMITDA,DA(2)=RMLODA,DA(1)=RMHCDA,DIK=DIC D ^DIK
- S DA(1)=RMLODA
- I '$D(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B")) S DIK="^RMPR(661.3,"_DA(1)_",1,",DA=RMHCDA D ^DIK
- I '$D(^RMPR(661.3,"C",RMDAHC)) S RMFLG=1
- W !,"**** Item has been removed from Location ",$P(^RMPR(661.3,RMLODA,0),U,1),!
- ;
- ;create item stattistics in file 661.2
- STAT D BAL^RMPR5NU1
- K DD,DO S DIC="^RMPR(661.2,",DIC(0)="L",X=DT,DLAYGO=661.2 D FILE^DICN
- G:$D(DTOUT)!(Y'>0) LOC S DA=+Y
- I 'RMFLG D
- .S RMMESF="Item Deactivated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": (-"_RMBA_")"
- .S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
- .S DIK=DIC D IX1^DIK
- ;
- DEAC I RMFLG D
- .S RMMESF="Deactivated by "_$E($P(^VA(200,DUZ,0),U,1),1,15)_": ("
- .S ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$J(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$J(RMAVA,0,2)
- .S DIK=DIC D IX1^DIK
- .S $P(^RMPR(661.1,RMDAHC,0),U,9)=0 W !,"**** HCPCS has been deactivated from Pros Inventory...."
- H 1 G LOC
- ;
- EXIT ;MAIN EXIT POINT
- N RMPRSITE,RMPR D KILL^XUSCLEAN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5NRE 2744 printed Jan 18, 2025@03:34:27 Page 2
- RMPR5NRE ;HIN/RVD-PROS INVENTORY REMOVE 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 SET X="NOW"
- DO ^%DT
- DO DD^%DT
- SET RMDAT=Y
- +4 WRITE @IOF
- +5 ;
- LOC ;get location
- +1 SET RMFLG=0
- +2 SET DZ="??"
- SET D="B"
- +3 KILL DTOUT,DUOUT,DIC("B"),DIC("S")
- +4 SET DIC="^RMPR(661.3,"
- SET DIC(0)="AEQM"
- +5 SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
- +6 SET DIC(0)="AEQM"
- +7 ;I $D(^RMPR(661.3,"B")) D DQ^DICQ
- +8 SET DIC("A")="Enter LOCATION: "
- DO MIX^DIC1
- +9 if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO EXIT
- SET RMLODA=+Y
- +10 SET RMLOC=$PIECE($GET(^RMPR(661.3,+Y,0)),U,1)
- +11 ;
- LIST ;list current HCPCS @ this Location
- +1 KILL DTOUT,DUOUT,DIC("S"),DIR
- +2 SET DIC("A")="Select HCPCS to Remove: "
- +3 SET DA(1)=RMLODA
- 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)"
- +4 SET DIC="^RMPR(661.3,"_RMLODA_",1,"
- DO ^DIC
- +5 IF +Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
- WRITE !,"** No HCPCS selected..."
- HANG 2
- GOTO LOC
- +6 SET RMHCDA=+Y
- SET RMDAHC=$PIECE(^RMPR(661.3,RMLODA,1,+Y,0),U,1)
- SET RMHCPC=$PIECE(^RMPR(661.1,RMDAHC,0),U,1)
- +7 ;
- ITEM if 'RMHCDA
- GOTO LIST
- KILL DIC
- +1 SET DA(1)=RMHCDA
- SET DA(2)=RMLODA
- SET DZ="??"
- SET D="B"
- +2 SET DIC("A")="Enter Item to Remove: "
- +3 SET DIC="^RMPR(661.3,"_DA(2)_",1,"_DA(1)_",1,"
- SET DIC(0)="AEMNQ"
- +4 ;I $D(^RMPR(661.1,RMDAHC,3,"B")) D DQ^DICQ
- +5 DO ^DIC
- if Y'>0!$DATA(DTOUT)!$DATA(DUOUT)
- GOTO LOC
- SET RMITDA=+Y
- +6 SET RM3=^RMPR(661.3,RMLODA,1,RMHCDA,1,RMITDA,0)
- +7 SET RMIT=$PIECE(RM3,U,1)
- SET RMBA=$PIECE(RM3,U,2)
- SET RMCO=$PIECE(RM3,U,3)
- SET RMSO=$PIECE(RM3,U,9)
- +8 SET RMDAIT=$PIECE(RMIT,"-",2)
- +9 SET RM1=^RMPR(661.1,RMDAHC,3,RMDAIT,0)
- +10 SET DIR("A")="Are you sure you want to DEACTIVATE/REMOVE this item (Y/N)"
- +11 SET DIR(0)="Y"
- DO ^DIR
- if $DATA(DTOUT)!(+Y=0)!$DATA(DUOUT)
- GOTO LOC
- +12 SET DA=RMITDA
- SET DA(2)=RMLODA
- SET DA(1)=RMHCDA
- SET DIK=DIC
- DO ^DIK
- +13 SET DA(1)=RMLODA
- +14 IF '$DATA(^RMPR(661.3,RMLODA,1,RMHCDA,1,"B"))
- SET DIK="^RMPR(661.3,"_DA(1)_",1,"
- SET DA=RMHCDA
- DO ^DIK
- +15 IF '$DATA(^RMPR(661.3,"C",RMDAHC))
- SET RMFLG=1
- +16 WRITE !,"**** Item has been removed from Location ",$PIECE(^RMPR(661.3,RMLODA,0),U,1),!
- +17 ;
- +18 ;create item stattistics in file 661.2
- STAT DO BAL^RMPR5NU1
- +1 KILL DD,DO
- SET DIC="^RMPR(661.2,"
- SET DIC(0)="L"
- SET X=DT
- SET DLAYGO=661.2
- DO FILE^DICN
- +2 if $DATA(DTOUT)!(Y'>0)
- GOTO LOC
- SET DA=+Y
- +3 IF 'RMFLG
- Begin DoDot:1
- +4 SET RMMESF="Item Deactivated by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_": (-"_RMBA_")"
- +5 SET ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
- +6 SET DIK=DIC
- DO IX1^DIK
- End DoDot:1
- +7 ;
- DEAC IF RMFLG
- Begin DoDot:1
- +1 SET RMMESF="Deactivated by "_$EXTRACT($PIECE(^VA(200,DUZ,0),U,1),1,15)_": ("
- +2 SET ^RMPR(661.2,DA,0)=DT_"^^^"_RMDAHC_"^^^"_DUZ_"^^"_RMIT_"^^^"_RMTOBA_"^"_RMMESF_"^"_$JUSTIFY(RMTOCO,0,2)_"^"_RMPR("STA")_"^"_RMLODA_"^"_$JUSTIFY(RMAVA,0,2)
- +3 SET DIK=DIC
- DO IX1^DIK
- +4 SET $PIECE(^RMPR(661.1,RMDAHC,0),U,9)=0
- WRITE !,"**** HCPCS has been deactivated from Pros Inventory...."
- End DoDot:1
- +5 HANG 1
- GOTO LOC
- +6 ;
- EXIT ;MAIN EXIT POINT
- +1 NEW RMPRSITE,RMPR
- DO KILL^XUSCLEAN
- +2 QUIT