PRCPSSQA.m

PRCPSSQA ;WISC/CC-Enter/edit privileged secondary IP users ;04/01

V ;;5.1;IFCAP;**24**;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 Q

 ;

AC ;I 'application coordinator W "You do not have access to this option" Q

 I '$$KEY^PRCPUREP("PRCPAQOH",DUZ) D EN^DDIOL("You are not authorized to give staff access to replace quantities.") Q

 ;

 N D,D0,D1,DA,DIC,DIDEL,DIE,DIK,DLAYGO,DQ,DR,INVPT,PRCF,PRCPPRIV,USER,X,Y,%

 ; ask site

 S %=0 F I="FY","PARAM","PER","QTR","SITE" I '+$G(PRC(I)) S %=1 Q

 I % S PRCF("X")="S" D ^PRCFSITE I '+$G(PRC("SITE")) K PRC,PRCP Q

 ;

 ; ask inventory point

 I '$D(PRCP("DPTYPE")) S PRCP("DPTYPE")="S"

 S DIC="^PRCP(445,",DIC(0)="AEQMOZ"

 S DIC("S")="I +^(0)=PRC(""SITE"")"

 S DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"

 S DIC("A")="Select Secondary Inventory Point: "

 S D="C",PRCPPRIV=1

 D IX^DIC K PRCPPRIV,DIC

 I Y<0 K PRC,PRCP Q

 S INVPT=Y Q:'$G(INVPT)

 I PRCP("DPTYPE")'="S" Q

 I '$D(^PRCP(445,+INVPT,0)) Q

 I $P($G(^PRCP(445,+INVPT,5)),"^",1)']"" D EN^DDIOL("This secondary is not linked to a supply station") Q

 ;

 L +^PRCP(445,+INVPT,8):3 I $T=0 D EN^DDIOL("The authorized user file is busy.  Please try again later.") Q

 ;

 ; purge inappropriate users

 S USER=0

 F  S USER=$O(^PRCP(445,+INVPT,8,USER)) Q:'+USER  D

 . S X=USER D CHK(+INVPT,.X) I X="" D

 . . D EN^DDIOL("Removing "_$P(^VA(200,USER,0),"^")_".....")

 . . S DIK="^PRCP(445,"_+INVPT_",8,",DA(1)=+INVPT,DA=+USER D ^DIK K DIK

 . . W "User DELETED !"

 ;

USERS ;  ask users

 I '$D(^PRCP(445,+INVPT,0)) D EN^DDIOL("This inventory point is not on file") Q

 I '$D(^PRCP(445,+INVPT,8,0)) S ^(0)="^445.026P^^"

 S DIC(0)="AEMQO"

 S DA=+INVPT,(DIC,DIE)="^PRCP(445,",DIDEL=445,DR=26,PRCPPRIV=1

 D ^DIE K PRCPPRIV,DIC,DIE

 Q

 ;

 ;

 ; invoked from this routine and input transform of .01 field in file 445.026

CHK(INVPT,USER) ; verify user has proper qualifications

 ;  INVPT   is the ien to file 445 (Inventory Point)

 ;  USER    is the ien to file 200

 ;

 I $P($G(^VA(200,USER,0)),"^",11),$P(^(0),"^",11)<DT D EN^DDIOL("You cannot ADD a terminated user.") S USER="" Q

 I '$D(^PRCP(445,INVPT,4,USER)) D EN^DDIOL("User has no access to this inventory point.  Contact the manager.") S USER="" Q

 I '$$KEY^PRCPUREP("PRCP2 MGRKEY",USER) S USER="" D EN^DDIOL("User needs the PRCP2 MGRKEY.") Q

 I '$$KEY^PRCPUREP("PRCPSSQOH",USER) S USER="" D EN^DDIOL("User needs the PRCPSSQOH key.") Q

 ;

EXIT L -^PRCP(445,+INVPT,8)

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCPSSQA   2508     printed  Mar 13, 2025@21:20:49                                                                                                                                                                                                    Page 2

PRCPSSQA  ;WISC/CC-Enter/edit privileged secondary IP users ;04/01

V         ;;5.1;IFCAP;**24**;Oct 20, 2000

 +1       ;Per VHA Directive 10-93-142, this routine should not be modified.

 +2        QUIT 

 +3       ;

AC        ;I 'application coordinator W "You do not have access to this option" Q

 +1        IF '$$KEY^PRCPUREP("PRCPAQOH",DUZ)

               DO EN^DDIOL("You are not authorized to give staff access to replace quantities.")

               QUIT 

 +2       ;

 +3        NEW D,D0,D1,DA,DIC,DIDEL,DIE,DIK,DLAYGO,DQ,DR,INVPT,PRCF,PRCPPRIV,USER,X,Y,%

 +4       ; ask site

 +5        SET %=0

           FOR I="FY","PARAM","PER","QTR","SITE"

               IF '+$GET(PRC(I))

                   SET %=1

                   QUIT 

 +6        IF %

               SET PRCF("X")="S"

               DO ^PRCFSITE

               IF '+$GET(PRC("SITE"))

                   KILL PRC,PRCP

                   QUIT 

 +7       ;

 +8       ; ask inventory point

 +9        IF '$DATA(PRCP("DPTYPE"))

               SET PRCP("DPTYPE")="S"

 +10       SET DIC="^PRCP(445,"

           SET DIC(0)="AEQMOZ"

 +11       SET DIC("S")="I +^(0)=PRC(""SITE"")"

 +12       SET DIC("S")=DIC("S")_",PRCP(""DPTYPE"")[$P(^PRCP(445,+Y,0),U,3)"

 +13       SET DIC("A")="Select Secondary Inventory Point: "

 +14       SET D="C"

           SET PRCPPRIV=1

 +15       DO IX^DIC

           KILL PRCPPRIV,DIC

 +16       IF Y<0

               KILL PRC,PRCP

               QUIT 

 +17       SET INVPT=Y

           if '$GET(INVPT)

               QUIT 

 +18       IF PRCP("DPTYPE")'="S"

               QUIT 

 +19       IF '$DATA(^PRCP(445,+INVPT,0))

               QUIT 

 +20       IF $PIECE($GET(^PRCP(445,+INVPT,5)),"^",1)']""

               DO EN^DDIOL("This secondary is not linked to a supply station")

               QUIT 

 +21      ;

 +22       LOCK +^PRCP(445,+INVPT,8):3

           IF $TEST=0

               DO EN^DDIOL("The authorized user file is busy.  Please try again later.")

               QUIT 

 +23      ;

 +24      ; purge inappropriate users

 +25       SET USER=0

 +26       FOR 

               SET USER=$ORDER(^PRCP(445,+INVPT,8,USER))

               if '+USER

                   QUIT 

               Begin DoDot:1

 +27               SET X=USER

                   DO CHK(+INVPT,.X)

                   IF X=""

                       Begin DoDot:2

 +28                       DO EN^DDIOL("Removing "_$PIECE(^VA(200,USER,0),"^")_".....")

 +29                       SET DIK="^PRCP(445,"_+INVPT_",8,"

                           SET DA(1)=+INVPT

                           SET DA=+USER

                           DO ^DIK

                           KILL DIK

 +30                       WRITE "User DELETED !"

                       End DoDot:2

               End DoDot:1

 +31      ;

USERS     ;  ask users

 +1        IF '$DATA(^PRCP(445,+INVPT,0))

               DO EN^DDIOL("This inventory point is not on file")

               QUIT 

 +2        IF '$DATA(^PRCP(445,+INVPT,8,0))

               SET ^(0)="^445.026P^^"

 +3        SET DIC(0)="AEMQO"

 +4        SET DA=+INVPT

           SET (DIC,DIE)="^PRCP(445,"

           SET DIDEL=445

           SET DR=26

           SET PRCPPRIV=1

 +5        DO ^DIE

           KILL PRCPPRIV,DIC,DIE

 +6        QUIT 

 +7       ;

 +8       ;

 +9       ; invoked from this routine and input transform of .01 field in file 445.026

CHK(INVPT,USER) ; verify user has proper qualifications

 +1       ;  INVPT   is the ien to file 445 (Inventory Point)

 +2       ;  USER    is the ien to file 200

 +3       ;

 +4        IF $PIECE($GET(^VA(200,USER,0)),"^",11)

               IF $PIECE(^(0),"^",11)<DT

                   DO EN^DDIOL("You cannot ADD a terminated user.")

                   SET USER=""

                   QUIT 

 +5        IF '$DATA(^PRCP(445,INVPT,4,USER))

               DO EN^DDIOL("User has no access to this inventory point.  Contact the manager.")

               SET USER=""

               QUIT 

 +6        IF '$$KEY^PRCPUREP("PRCP2 MGRKEY",USER)

               SET USER=""

               DO EN^DDIOL("User needs the PRCP2 MGRKEY.")

               QUIT 

 +7        IF '$$KEY^PRCPUREP("PRCPSSQOH",USER)

               SET USER=""

               DO EN^DDIOL("User needs the PRCPSSQOH key.")

               QUIT 

 +8       ;

EXIT       LOCK -^PRCP(445,+INVPT,8)

 +1        QUIT