Routine: PRCHDEP4

PRCHDEP4 ;WISC/RWS-SUPPLEMENTAL ROUTINES CALLED FROM PRCHDEP3 ;4/20/92  9:34 AM

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

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

EDIT G:$D(PRCHENT) E2 S %A=" Do you want to generate the codesheets",%B=" Answer NO if you do not wish to build the LOG codesheets at this time.",%=1 D ^PRCFYN I %=-1 K PRCHPO Q

 G:%=1 E2 W !!," Do you want to remove this P.O. or Receiving Report from the list of",!,"pending codesheets?"

 S %A="REMOVE FROM LIST",%B="If you answer YES, and later want to generate codesheets, you will have",%B(1)="to use the 'Create a Codesheet' option.",%=2 D ^PRCFYN D:%=1 R S DA=PRCHPO,DIC="^PRC(442," D UNLCK^PRCHDEP3 K PRCHPO Q

E2 S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)

 S X=$G(^PRC(442,PRCHPO,17)),Y=$G(^(18))

 W !!,"P.O.(PAT) No.: "_PRCHPONO,!,"Document Identifier: ",$P(Y,U,3) W:PRCHN("SC")=1 ?35,"Requisition Number: ",$P(Y,U,10) W !

 W:PRCHN("SFC")'=2&(PRCHN("SC")'=0) "Department No.: ",$P(X,U,1),! W "Source Code: "_PRCHN("SC"),!

SETUP ;S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$S($D(^PRCD(420.8,+$P(^(1),U,7),0)):$P(^(0),U,1),1:"") S:"013"[PRCHN("SC") PRCHNRQ=1

 S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$P($G(^PRCD(420.8,+$P(^(1),U,7),0)),U,1) S:"013"[PRCHN("SC") PRCHNRQ=1

 ;S PRCHN("MP")=$S($D(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)):$P(^(0),U,3),1:"")

 S PRCHN("MP")=$P($G(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)),U,3)

 ;S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$S($D(^(1)):$P(^(1),U,17),1:"") Q

 S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$P($G(^(1)),U,17)

OBL Q:'$P(^PRC(442,PRCHPO,0),U,12)  I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,12) W $C(7),!!!,"Control Point Obligated Balances have already been updated.",!! Q

 W !! S %A="  Update Control Point Obligated Balance",%B="  Review the Order first to make sure it is correct. This step should be",%B(1)="done to make sure the Control Point Balance matches CALM."

 S %=2 D ^PRCFYN I %'=1 K PRCHPO Q

 D OBL^PRCHNRQ

ASK W !!!,$C(7),"**** Do you want to print a report showing code sheets to be created? ****" S %A="PRINT REPORT",%B="Answer 'Y' to see what orders have not yet had code sheets generated",%=2

 D YN^PRCFYN

R ;REMOVE P.O. OR RECEIVING REPORT FROM PENDING LIST

 I PRCHTYP="A" K ^PRC(442,"AE","N",PRCHPO) Q

 I PRCHTYP="R" K ^PRC(442,"AF","N",PRCHPO,PRCHRPT)

EN001 S PRCFA("DICS")="I Y=401",PRCFA("TTF")=401

 D GT^PRCHEC I '% D UNLCK^PRCHDEP3 G EN01^PRCHDEP3

 D B401

 D SC^PRCHCS0

 D ^PRCHCS

 G EN01^PRCHDEP3

B401 ;DEPOT DUE-IN TRANSACTION 401

 S PRCHTP(1,1)="S X=PRCHPO;344",PRCHTP(1,2)=".1;385",PRCHTP(1,3)="D DOCID^PRCHCS2;344",PRCHTP(1,4)="7;406"

 S PRCHTP(1,5)="D:'$D(PRCFA(1)) DEFAULT^PRCHDEP4 S X=PRCFA(1);408"

 S PRCHTP(1,6)="S X=PRCFA(2);384"

 S PRCHTP(1,7)="S Y=$E(PRCFA(3),1,5),PRCFLN=5 D LZF^PRCFU S X=Y K Y;386"

 S PRCHTP(1,8)="S X=PRCFA(4);387"

 S PRCHTP(1,9)="S X=401;3"

 S PRCHTP(1,10)="S X=1;396"

 S PRCHTP(1,11)="S X="" "";389"

 S PRCHTP(1,12)="S X=""00000"";390"

 S PRCHTP(1,13)="S X=""00000"";391"

 S PRCHTP(1,14)="S X=""00000"";392"

 S PRCHTP(2,1)=".01;300",PRCHTP(2,2)="2;405",PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308",PRCHTP(2,4)="3;303",PRCHTP(2,5)="5;388"

DEFAULT S DR="[PRCH-DEP LOG 401]",DIE=423 D ^DIE

 Q:'$D(^PRCF(423,DA,0))  S PRCFA(1)=$P(^(304),U,16)

 S PRCFA(2)=$P(^PRCF(423,DA,302),U,9)

 S PRCFA(3)=$P(^PRCF(423,DA,303),U,1)

 S PRCFA(4)=$P(^PRCF(423,DA,303),U,2)

B431 ;DEPOT 431 AND 434 TRANSACTIONS

 S PRCHTP(1,1)="S X=PRCHPO;5.1"

 S PRCHTP(2,1)=".01;300"

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDEP4   3640     printed  Mar 13, 2025@21:11:25                                                                                                                                                                                                    Page 2

PRCHDEP4  ;WISC/RWS-SUPPLEMENTAL ROUTINES CALLED FROM PRCHDEP3 ;4/20/92  9:34 AM

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

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

EDIT       if $DATA(PRCHENT)

               GOTO E2

           SET %A=" Do you want to generate the codesheets"

           SET %B=" Answer NO if you do not wish to build the LOG codesheets at this time."

           SET %=1

           DO ^PRCFYN

           IF %=-1

               KILL PRCHPO

               QUIT

 +1        if %=1

               GOTO E2

           WRITE !!," Do you want to remove this P.O. or Receiving Report from the list of",!,"pending codesheets?"

 +2        SET %A="REMOVE FROM LIST"

           SET %B="If you answer YES, and later want to generate codesheets, you will have"

           SET %B(1)="to use the 'Create a Codesheet' option."

           SET %=2

           DO ^PRCFYN

           if %=1

               DO R

           SET DA=PRCHPO

           SET DIC="^PRC(442,"

           DO UNLCK^PRCHDEP3

           KILL PRCHPO

           QUIT

E2         SET PRCHPONO=$PIECE(^PRC(442,PRCHPO,0),U,1)

 +1        SET X=$GET(^PRC(442,PRCHPO,17))

           SET Y=$GET(^(18))

 +2        WRITE !!,"P.O.(PAT) No.: "_PRCHPONO,!,"Document Identifier: ",$PIECE(Y,U,3)

           if PRCHN("SC")=1

               WRITE ?35,"Requisition Number: ",$PIECE(Y,U,10)

           WRITE !

 +3        if PRCHN("SFC")'=2&(PRCHN("SC")'=0)

               WRITE "Department No.: ",$PIECE(X,U,1),!

           WRITE "Source Code: "_PRCHN("SC"),!

 +4        QUIT

 +5       ;

SETUP     ;S PRCHN("SC")="" I $D(^PRC(442,PRCHPO,1)) S PRCHN("SC")=$S($D(^PRCD(420.8,+$P(^(1),U,7),0)):$P(^(0),U,1),1:"") S:"013"[PRCHN("SC") PRCHNRQ=1

 +1        SET PRCHN("SC")=""

           IF $DATA(^PRC(442,PRCHPO,1))

               SET PRCHN("SC")=$PIECE($GET(^PRCD(420.8,+$PIECE(^(1),U,7),0)),U,1)

               if "013"[PRCHN("SC")

                   SET PRCHNRQ=1

 +2       ;S PRCHN("MP")=$S($D(^PRCD(442.5,+$P(^PRC(442,PRCHPO,0),U,2),0)):$P(^(0),U,3),1:"")

 +3        SET PRCHN("MP")=$PIECE($GET(^PRCD(442.5,+$PIECE(^PRC(442,PRCHPO,0),U,2),0)),U,3)

 +4       ;S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19),PRCHEMG=$S($D(^(1)):$P(^(1),U,17),1:"") Q

 +5        SET PRCHN("SFC")=$PIECE(^PRC(442,PRCHPO,0),U,19)

           SET PRCHEMG=$PIECE($GET(^(1)),U,17)

 +6        QUIT

 +7       ;

OBL        if '$PIECE(^PRC(442,PRCHPO,0),U,12)

               QUIT

           IF $DATA(^PRC(442,PRCHPO,18))

               IF $PIECE(^(18),U,12)

                   WRITE $CHAR(7),!!!,"Control Point Obligated Balances have already been updated.",!!

                   QUIT

 +1        WRITE !!

           SET %A="  Update Control Point Obligated Balance"

           SET %B="  Review the Order first to make sure it is correct. This step should be"

           SET %B(1)="done to make sure the Control Point Balance matches CALM."

 +2        SET %=2

           DO ^PRCFYN

           IF %'=1

               KILL PRCHPO

               QUIT

 +3        DO OBL^PRCHNRQ

 +4        QUIT

 +5       ;

ASK        WRITE !!!,$CHAR(7),"**** Do you want to print a report showing code sheets to be created? ****"

           SET %A="PRINT REPORT"

           SET %B="Answer 'Y' to see what orders have not yet had code sheets generated"

           SET %=2

 +1        DO YN^PRCFYN

 +2        QUIT

 +3       ;

R         ;REMOVE P.O. OR RECEIVING REPORT FROM PENDING LIST

 +1        IF PRCHTYP="A"

               KILL ^PRC(442,"AE","N",PRCHPO)

               QUIT

 +2        IF PRCHTYP="R"

               KILL ^PRC(442,"AF","N",PRCHPO,PRCHRPT)

 +3        QUIT

 +4       ;

EN001      SET PRCFA("DICS")="I Y=401"

           SET PRCFA("TTF")=401

 +1        DO GT^PRCHEC

           IF '%

               DO UNLCK^PRCHDEP3

               GOTO EN01^PRCHDEP3

 +2        DO B401

 +3        DO SC^PRCHCS0

 +4        DO ^PRCHCS

 +5        GOTO EN01^PRCHDEP3

 +6       ;

B401      ;DEPOT DUE-IN TRANSACTION 401

 +1        SET PRCHTP(1,1)="S X=PRCHPO;344"

           SET PRCHTP(1,2)=".1;385"

           SET PRCHTP(1,3)="D DOCID^PRCHCS2;344"

           SET PRCHTP(1,4)="7;406"

 +2        SET PRCHTP(1,5)="D:'$D(PRCFA(1)) DEFAULT^PRCHDEP4 S X=PRCFA(1);408"

 +3        SET PRCHTP(1,6)="S X=PRCFA(2);384"

 +4        SET PRCHTP(1,7)="S Y=$E(PRCFA(3),1,5),PRCFLN=5 D LZF^PRCFU S X=Y K Y;386"

 +5        SET PRCHTP(1,8)="S X=PRCFA(4);387"

 +6        SET PRCHTP(1,9)="S X=401;3"

 +7        SET PRCHTP(1,10)="S X=1;396"

 +8        SET PRCHTP(1,11)="S X="" "";389"

 +9        SET PRCHTP(1,12)="S X=""00000"";390"

 +10       SET PRCHTP(1,13)="S X=""00000"";391"

 +11       SET PRCHTP(1,14)="S X=""00000"";392"

 +12       SET PRCHTP(2,1)=".01;300"

           SET PRCHTP(2,2)="2;405"

           SET PRCHTP(2,3)="S X=$P(PRCHDIC1(2,0),U,13),X=$P(X,""-"",2)_$P(X,""-"",3)_$P(X,""-"",4);308"

           SET PRCHTP(2,4)="3;303"

           SET PRCHTP(2,5)="5;388"

 +13       QUIT

 +14      ;

DEFAULT    SET DR="[PRCH-DEP LOG 401]"

           SET DIE=423

           DO ^DIE

 +1        if '$DATA(^PRCF(423,DA,0))

               QUIT

           SET PRCFA(1)=$PIECE(^(304),U,16)

 +2        SET PRCFA(2)=$PIECE(^PRCF(423,DA,302),U,9)

 +3        SET PRCFA(3)=$PIECE(^PRCF(423,DA,303),U,1)

 +4        SET PRCFA(4)=$PIECE(^PRCF(423,DA,303),U,2)

 +5        QUIT

 +6       ;

B431      ;DEPOT 431 AND 434 TRANSACTIONS

 +1        SET PRCHTP(1,1)="S X=PRCHPO;5.1"

 +2        SET PRCHTP(2,1)=".01;300"

 +3        QUIT

PRCHDEP4.m