RMPR5NDL.m

RMPR5NDL ;HIN/RVD-PROS INVENTORY DELETE UTILITY ;9/03/99

 ;;3.0;PROSTHETICS;**37,51**;Feb 09, 1996

 ;

 ; ODJ - patch 51 - 10/20/00 - implement requirement for dual RMPR

 ;                             manager signatories before deleting

 ;                             locations.

 ;

 D DIV4^RMPRSIT I $D(Y),(Y<0) K DIC("B") Q

 S X="NOW" D ^%DT

LOC ;ask for Location.

 W @IOF,!!,"Delete an Inventory Location.....",!

 W !,"This option now requires the electronic signatures of 2 users"

 W !,"holding the RMPRMANAGER key to be entered before a location"

 W !,"will be deleted.",!

 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

CHK D STOCK(RMLODA) ;check and display number&quantities of items

OSIG I '$$GETO(DUZ) G EXIT ;get other signature exit if not OK

ESIG I $D(XQUSER) D

 . W !!,XQUSER," please..."

 . Q

 E  D

 . W !!,$P(^VA(200,DUZ,0),"^",1)," please..."

 . Q

 D SIG^XUSESIG G:X1="" EXIT ;get electronic sig. of main user

DEL ;delete a location

 S DIR(0)="Y",DIR("B")="N"

 W !

 S DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "

 D ^DIR I $D(DTOUT)!$D(DUOUT)!(Y="^")!(Y=0) W !,"Nothing Deleted.." G EXIT

 L +^RMPR(661.3,RMLODA):2

 I '$T W !,"Record in use. Try again later..." G EXIT

 I Y>0 S DIK="^RMPR(661.3,",DA=RMLODA D ^DIK W:'$D(^RMPR(661.3,RMLODA,0)) !,"Location is deleted!!!!" H 2

 ;

 ;

EXIT ;MAIN EXIT POINT

 N RMPR,RMPRSITE D KILL^XUSCLEAN

 Q

 ;

 ; Patch 51 - get electronic signatures from 2 RMPR managers in order

 ;            to OK a delete

GETO(RMPRDUZ) ;

 N RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS

 W !!,"Pease ask another user with the RMPRMANAGER key to"

 W !,"enter their user name and electronic signature.",!

 S RMPROK=0

 S RMPRKEYS("RMPRMANAGER")=""

 S RMPRUSR1("DUZ")=RMPRDUZ

 I $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'="" G GETOKX

 S DUZ=RMPRUSR2("DUZ")

 W !,RMPRUSR2("NAME")," please..."

 D SIG^XUSESIG I X1="" G GETOKX

 S RMPROK=1

GETOKX Q RMPROK

 ;

 ; Get 2nd User and ensure they have RMPRMANAGER key

GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;

 N DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ

 S DUZ=RMPRUSR1("DUZ")

USR2E K RMPRUSR2

 S DIC="^VA(200,"

 S DIC(0)="ABEQ"

 S DIC("A")="Enter user name of 2nd manager:"

 D ^DIC

 I Y=-1 S RMPREXC="^" G USR2X

 S RMPRUSR2("DUZ")=$P(Y,U,1)

 ;

 ; User 2 can't be same as user 1

 I RMPRUSR2("DUZ")=RMPRUSR1("DUZ") D  G USR2E

 . W !,"The 2nd manager must be different to the manager logged on."

 . Q

 ;

 ; User 2 must have defined security keys

 S RMPRKEY=""

 F  S RMPRKEY=$O(RMPRKEYS(RMPRKEY)) Q:RMPRKEY=""  Q:$D(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))

 I RMPRKEY="" D  G USR2E

 . W !,"The 2nd manager does not have the correct security key set up."

 . Q

 ;

 ; User 2 verified

 S RMPRUSR2("NAME")=$P(Y,U,2)

 S RMPREXC=""

USR2X Q RMPREXC

 ;

 ; Get number of HCPC items, quantity in stock and cost for location

STOCK(RMPRILOC) ;

 N IEN1,IEN2,S,RMPRSTK

 K RMPRSTK S RMPRSTK("ITEMS")=0

 S IEN1=0

 F  S IEN1=$O(^RMPR(661.3,RMPRILOC,1,IEN1)) Q:'+IEN1  D

 . S IEN2=0

 . F  S IEN2=$O(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2)) Q:'+IEN2  D

 .. S RMPRSTK("ITEMS")=1+RMPRSTK("ITEMS")

 .. S S=$G(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2,0))

 .. S RMPRSTK("QOH")=$P(S,"^",2)+$G(RMPRSTK("QOH"))

 .. S RMPRSTK("COST")=$P(S,"^",3)+$G(RMPRSTK("COST"))

 .. Q

 . Q

 W !,"The above location contains "

 W RMPRSTK("ITEMS")," types of items"

 I RMPRSTK("ITEMS")=0 D

 . W "."

 . Q

 E  D

 . W ", ",!,"with a total quantity of ",RMPRSTK("QOH")

 . W " and cost of $",RMPRSTK("COST"),"."

 . Q

 W !

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---RMPR5NDL   3748     printed  Mar 13, 2025@21:38:09                                                                                                                                                                                                    Page 2

RMPR5NDL  ;HIN/RVD-PROS INVENTORY DELETE UTILITY ;9/03/99

 +1       ;;3.0;PROSTHETICS;**37,51**;Feb 09, 1996

 +2       ;

 +3       ; ODJ - patch 51 - 10/20/00 - implement requirement for dual RMPR

 +4       ;                             manager signatories before deleting

 +5       ;                             locations.

 +6       ;

 +7        DO DIV4^RMPRSIT

           IF $DATA(Y)

               IF (Y<0)

                   KILL DIC("B")

                   QUIT 

 +8        SET X="NOW"

           DO ^%DT

LOC       ;ask for Location.

 +1        WRITE @IOF,!!,"Delete an Inventory Location.....",!

 +2        WRITE !,"This option now requires the electronic signatures of 2 users"

 +3        WRITE !,"holding the RMPRMANAGER key to be entered before a location"

 +4        WRITE !,"will be deleted.",!

 +5        KILL DTOUT,DUOUT,DIC("B")

 +6        SET DZ="??"

           SET D="B"

           SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"

 +7        SET DIC="^RMPR(661.3,"

           SET DIC(0)="AEQM"

 +8        SET D="B"

           SET DIC("A")="Enter Pros Location: "

           DO MIX^DIC1

 +9        if $DATA(DTOUT)!$DATA(DUOUT)!(Y'>0)

               GOTO EXIT

           SET (DA,RMLODA)=+Y

CHK       ;check and display number&quantities of items

           DO STOCK(RMLODA)

OSIG      ;get other signature exit if not OK

           IF '$$GETO(DUZ)

               GOTO EXIT

ESIG       IF $DATA(XQUSER)

               Begin DoDot:1

 +1                WRITE !!,XQUSER," please..."

 +2                QUIT 

               End DoDot:1

 +3       IF '$TEST

               Begin DoDot:1

 +4                WRITE !!,$PIECE(^VA(200,DUZ,0),"^",1)," please..."

 +5                QUIT 

               End DoDot:1

 +6       ;get electronic sig. of main user

           DO SIG^XUSESIG

           if X1=""

               GOTO EXIT

DEL       ;delete a location

 +1        SET DIR(0)="Y"

           SET DIR("B")="N"

 +2        WRITE !

 +3        SET DIR("A")="Are you sure you want to DELETE this LOCATION (Y/N) "

 +4        DO ^DIR

           IF $DATA(DTOUT)!$DATA(DUOUT)!(Y="^")!(Y=0)

               WRITE !,"Nothing Deleted.."

               GOTO EXIT

 +5        LOCK +^RMPR(661.3,RMLODA):2

 +6        IF '$TEST

               WRITE !,"Record in use. Try again later..."

               GOTO EXIT

 +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

 +8       ;

 +9       ;

EXIT      ;MAIN EXIT POINT

 +1        NEW RMPR,RMPRSITE

           DO KILL^XUSCLEAN

 +2        QUIT 

 +3       ;

 +4       ; Patch 51 - get electronic signatures from 2 RMPR managers in order

 +5       ;            to OK a delete

GETO(RMPRDUZ) ;

 +1        NEW RMPRMGR,RMPROK,RMPRUSR1,RMPRUSR2,X,X1,DUZ,RMPRKEYS

 +2        WRITE !!,"Pease ask another user with the RMPRMANAGER key to"

 +3        WRITE !,"enter their user name and electronic signature.",!

 +4        SET RMPROK=0

 +5        SET RMPRKEYS("RMPRMANAGER")=""

 +6        SET RMPRUSR1("DUZ")=RMPRDUZ

 +7        IF $$GETUSR2(.RMPRUSR2,.RMPRKEYS,.RMPRUSR1)'=""

               GOTO GETOKX

 +8        SET DUZ=RMPRUSR2("DUZ")

 +9        WRITE !,RMPRUSR2("NAME")," please..."

 +10       DO SIG^XUSESIG

           IF X1=""

               GOTO GETOKX

 +11       SET RMPROK=1

GETOKX     QUIT RMPROK

 +1       ;

 +2       ; Get 2nd User and ensure they have RMPRMANAGER key

GETUSR2(RMPRUSR2,RMPRKEYS,RMPRUSR1) ;

 +1        NEW DIC,X,Y,DLAYGO,DTOUT,DUOUT,RMPREXC,RMPRKEY,DUZ

 +2        SET DUZ=RMPRUSR1("DUZ")

USR2E      KILL RMPRUSR2

 +1        SET DIC="^VA(200,"

 +2        SET DIC(0)="ABEQ"

 +3        SET DIC("A")="Enter user name of 2nd manager:"

 +4        DO ^DIC

 +5        IF Y=-1

               SET RMPREXC="^"

               GOTO USR2X

 +6        SET RMPRUSR2("DUZ")=$PIECE(Y,U,1)

 +7       ;

 +8       ; User 2 can't be same as user 1

 +9        IF RMPRUSR2("DUZ")=RMPRUSR1("DUZ")

               Begin DoDot:1

 +10               WRITE !,"The 2nd manager must be different to the manager logged on."

 +11               QUIT 

               End DoDot:1

               GOTO USR2E

 +12      ;

 +13      ; User 2 must have defined security keys

 +14       SET RMPRKEY=""

 +15       FOR 

               SET RMPRKEY=$ORDER(RMPRKEYS(RMPRKEY))

               if RMPRKEY=""

                   QUIT 

               if $DATA(^XUSEC(RMPRKEY,RMPRUSR2("DUZ")))

                   QUIT 

 +16       IF RMPRKEY=""

               Begin DoDot:1

 +17               WRITE !,"The 2nd manager does not have the correct security key set up."

 +18               QUIT 

               End DoDot:1

               GOTO USR2E

 +19      ;

 +20      ; User 2 verified

 +21       SET RMPRUSR2("NAME")=$PIECE(Y,U,2)

 +22       SET RMPREXC=""

USR2X      QUIT RMPREXC

 +1       ;

 +2       ; Get number of HCPC items, quantity in stock and cost for location

STOCK(RMPRILOC) ;

 +1        NEW IEN1,IEN2,S,RMPRSTK

 +2        KILL RMPRSTK

           SET RMPRSTK("ITEMS")=0

 +3        SET IEN1=0

 +4        FOR 

               SET IEN1=$ORDER(^RMPR(661.3,RMPRILOC,1,IEN1))

               if '+IEN1

                   QUIT 

               Begin DoDot:1

 +5                SET IEN2=0

 +6                FOR 

                       SET IEN2=$ORDER(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2))

                       if '+IEN2

                           QUIT 

                       Begin DoDot:2

 +7                        SET RMPRSTK("ITEMS")=1+RMPRSTK("ITEMS")

 +8                        SET S=$GET(^RMPR(661.3,RMPRILOC,1,IEN1,1,IEN2,0))

 +9                        SET RMPRSTK("QOH")=$PIECE(S,"^",2)+$GET(RMPRSTK("QOH"))

 +10                       SET RMPRSTK("COST")=$PIECE(S,"^",3)+$GET(RMPRSTK("COST"))

 +11                       QUIT 

                       End DoDot:2

 +12               QUIT 

               End DoDot:1

 +13       WRITE !,"The above location contains "

 +14       WRITE RMPRSTK("ITEMS")," types of items"

 +15       IF RMPRSTK("ITEMS")=0

               Begin DoDot:1

 +16               WRITE "."

 +17               QUIT 

               End DoDot:1

 +18      IF '$TEST

               Begin DoDot:1

 +19               WRITE ", ",!,"with a total quantity of ",RMPRSTK("QOH")

 +20               WRITE " and cost of $",RMPRSTK("COST"),"."

 +21               QUIT 

               End DoDot:1

 +22       WRITE !

 +23       QUIT