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"),!
Q
;
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)
Q
;
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
Q
;
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
Q
;
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)
Q
;
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"
Q
;
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)
Q
;
B431 ;DEPOT 431 AND 434 TRANSACTIONS
S PRCHTP(1,1)="S X=PRCHPO;5.1"
S PRCHTP(2,1)=".01;300"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDEP4 3640 printed Oct 16, 2024@18:07:23 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
