PRCSRIG.m

PRCSRIG ;WISC/SAW-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE ;1.29.98

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

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

 D DUZ^PRCFSITE Q:'$D(PRC("PER"))  D DISP^PRCOSS3

 W !!,"This option generates requests with permanent transaction numbers from",!,"entries in the repetitive item list file.",!,"Are you sure you are ready to proceed" S %=2 D YN^DICN G EXIT:%=2!(%<0),PRCSRIG:%=0

 W ! S DIC="^PRCS(410.3,",DIC(0)="AEMQ",DIC("S")="S PRC(""SITE"")=$P(^(0),""-""),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" D ^DIC K DIC("S") I Y'>0 G EXIT

 S PRCSRID0=+Y,PRC("SITE")=$P(^PRCS(410.3,PRCSRID0,0),"-"),PRC("CP")=$P(^(0),"-",4)

 S:'$D(PRC("SST")) PRC("SST")="" S DIC("B")=PRC("SST") I $D(^PRC(411,"UP",+PRC("SITE"))) S DIC="^PRC(411,",DIC(0)="AEQZ",DIC("A")="Select SUBSTATION: ",DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")" D ^DIC I Y>0 S PRC("SST")=+Y

 S (A,PRCSAPP)=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3) I PRCSAPP["_/_" D FY2^PRCSUT2 G EXIT:X="^"

 D FY^PRCSUT Q:PRC("FY")'?2N

 S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"))

 I '$D(PRC("BBFY")) W !,"Please check the accounting elements for FY ",PRC("FY") G EXIT

 S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")) S (A,PRCSAPP)=$P(PRC("ACC"),"^",11)

 I PRCSAPP["_/_" D FY2^PRCSUT2 G EXIT:X="^"

 L +^PRCS(410.3,PRCSRID0,0):15 S PRCSL=$T I PRCSL=0 W !!,$C(7),"This record is being accessed by another user.  Please try later." G EXIT

 S $P(^PRCS(410.3,PRCSRID0,0),U,5)=1 L -^PRCS(410.3,PRCSRID0,0) D CLOSE^PRCOSS3

 W !!,"You may use either the current quarter or the repetitive item",!,"list quarter to generate requests."

ASKQTR N PQTR S (%,PQTR)=1 W !,"Use repetitive item list quarter" D YN^DICN Q:%=-1  S:%=2 PQTR=0 G:%=0 ASKQTR

 S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS G EXIT:POP I $D(IO("Q")) S ZTRTN="^PRCSRIG1",ZTSAVE("PRC*")="",ZTSAVE("PQTR")="",ZTSAVE("C")="",ZTSAVE("PRCSRID0")="",ZTSAVE("PRC(""PER"")")="",ZTSAVE("PRCSAPP")="" D ^%ZTLOAD G EXIT

 D ^PRCSRIG1

EXIT K %,%ZIS,B,DIC,PRCSRID0,Y,ZTRTN,ZTSAVE Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCSRIG   2161     printed  Apr 09, 2024@21:21:26                                                                                                                                                                                                     Page 2

PRCSRIG   ;WISC/SAW-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE ;1.29.98

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

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

 +2        DO DUZ^PRCFSITE

           if '$DATA(PRC("PER"))

               QUIT 

           DO DISP^PRCOSS3

 +3        WRITE !!,"This option generates requests with permanent transaction numbers from",!,"entries in the repetitive item list file.",!,"Are you sure you are ready to proceed"

           SET %=2

           DO YN^DICN

           if %=2!(%<0)

               GOTO EXIT

           if %=0

               GOTO PRCSRIG

 +4        WRITE !

           SET DIC="^PRCS(410.3,"

           SET DIC(0)="AEMQ"

           SET DIC("S")="S PRC(""SITE"")=$P(^(0),""-""),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"

           DO ^DIC

           KILL DIC("S")

           IF Y'>0

               GOTO EXIT

 +5        SET PRCSRID0=+Y

           SET PRC("SITE")=$PIECE(^PRCS(410.3,PRCSRID0,0),"-")

           SET PRC("CP")=$PIECE(^(0),"-",4)

 +6        if '$DATA(PRC("SST"))

               SET PRC("SST")=""

           SET DIC("B")=PRC("SST")

           IF $DATA(^PRC(411,"UP",+PRC("SITE")))

               SET DIC="^PRC(411,"

               SET DIC(0)="AEQZ"

               SET DIC("A")="Select SUBSTATION: "

               SET DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")"

               DO ^DIC

               IF Y>0

                   SET PRC("SST")=+Y

 +7        SET (A,PRCSAPP)=$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3)

           IF PRCSAPP["_/_"

               DO FY2^PRCSUT2

               if X="^"

                   GOTO EXIT

 +8        DO FY^PRCSUT

           if PRC("FY")'?2N

               QUIT 

 +9        SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"))

 +10       IF '$DATA(PRC("BBFY"))

               WRITE !,"Please check the accounting elements for FY ",PRC("FY")

               GOTO EXIT

 +11       SET PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))

           SET (A,PRCSAPP)=$PIECE(PRC("ACC"),"^",11)

 +12       IF PRCSAPP["_/_"

               DO FY2^PRCSUT2

               if X="^"

                   GOTO EXIT

 +13       LOCK +^PRCS(410.3,PRCSRID0,0):15

           SET PRCSL=$TEST

           IF PRCSL=0

               WRITE !!,$CHAR(7),"This record is being accessed by another user.  Please try later."

               GOTO EXIT

 +14       SET $PIECE(^PRCS(410.3,PRCSRID0,0),U,5)=1

           LOCK -^PRCS(410.3,PRCSRID0,0)

           DO CLOSE^PRCOSS3

 +15       WRITE !!,"You may use either the current quarter or the repetitive item",!,"list quarter to generate requests."

ASKQTR     NEW PQTR

           SET (%,PQTR)=1

           WRITE !,"Use repetitive item list quarter"

           DO YN^DICN

           if %=-1

               QUIT 

           if %=2

               SET PQTR=0

           if %=0

               GOTO ASKQTR

 +1        SET %ZIS("B")="HOME"

           SET %ZIS="MQ"

           DO ^%ZIS

           if POP

               GOTO EXIT

           IF $DATA(IO("Q"))

               SET ZTRTN="^PRCSRIG1"

               SET ZTSAVE("PRC*")=""

               SET ZTSAVE("PQTR")=""

               SET ZTSAVE("C")=""

               SET ZTSAVE("PRCSRID0")=""

               SET ZTSAVE("PRC(""PER"")")=""

               SET ZTSAVE("PRCSAPP")=""

               DO ^%ZTLOAD

               GOTO EXIT

 +2        DO ^PRCSRIG1

EXIT       KILL %,%ZIS,B,DIC,PRCSRID0,Y,ZTRTN,ZTSAVE

           QUIT