PRCH410 ;WISC/KMB/DXH/DGL - CREATE 2237 FROM PURCHASE CARD ORDER ; 4/4/00 7:56am
;;5.1;IFCAP;**123,171,181,186,192,199**;Oct 20, 2000;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
; prcsip is package-wide variable for inv pt that may or may not be
; passed to this routine
;
;PRC*5.1*181 Split the update for setting File 442, node 23 piece 23
; (410 pointer) and piece 13 (sort group) into two sets,
; 410 pointer before the Sort Group query and Sort Group
; after. This eliminates a user crashing at Sort Group
; query and creating 2 410 entries due to missing 410
; pointer in file 442 that was not set due to Sort
; Group query failure.
;
;PRC*5.1*186 RGB 7/1/2014 Fix for 3 Remedy tickets:
; INC752542 Fix duplicate entries in file 443 by changing
; the direct field 1.5 and x-ref 'AC' set to
; Fileman update of status field.
; INC952389 Modify logic to insure when All/Delivery switch
; is set that the DO affects the Running Balance
; report when auto obligated. Also, modified the
; EDI check in same area for logic clarity.
;
;PRC*5.1*192 RGB 12/16/15 Modify Delivery Order auto obligation file
; 410 set for net to field #92 to ensure Running Balance
; reflects the net amount for order.
;PRC*5.1*199 Check PRCRMPR switch on GUI Prosthetics order filing to
; skip inventory point selection query for FCPs linked to
; multiple inventories.
;
START ;
N VV,ST,Y,Z,Z0,Z1,Z2,I,J,CCEN,ESTS,NET,SERV,EMER,COUNT,COUNT1,L,PDUZ,FY,QTR,CP,LOC,ADATE,TDATE,SDATE,LL,PC,PCREF,XDA
N SCP,SGRP,COR,VEN,VEND
Q:'$D(DA) Q:+DA=0 S XDA=DA
S Z0=$G(^PRC(442,XDA,0)),PRC("SITE")=$P(Z0,"-"),CP=$P(Z0,"^",3),SCP=$P(CP," "),PRC("SST")=$P($G(^PRC(442,XDA,23)),"^",7),PCREF=$P(Z0,"^"),PCREF=$P(PCREF,"-",2)
S TDATE=$$DATE^PRC0C($P($G(^PRC(442,XDA,1)),"^",15),"I"),PRC("FY")=$E(TDATE,3,4),PRC("QTR")=$P(TDATE,"^",2),(TDATE,SDATE)=$P($$DATE^PRC0C("T","E"),"^",7)
S CCEN=$P(Z0,"^",5),ESTS=$P(Z0,"^",13),ADATE=$P(Z0,"^",10)
I CCEN'="" S CCEN=$E($P(^PRCD(420.1,CCEN,0),"^"),1,30)
S Z1=$G(^PRC(442,XDA,1)),(VV,VEND)=$P(Z1,"^"),SERV=$P(Z1,"^",2),EMER=$P(Z1,"^",17),LOC=$P(Z1,"^",11),PDUZ=DUZ
S ST="ST" S:EMER="Y" ST="EM"
S PRC("CP")=+SCP
I $G(PRCSIP) I '$O(^PRC(420,PRC("SITE"),1,PRC("CP"),7,"B",PRCSIP,0)) K PRCSIP ; Kill inventory point if not match FCP
I '$G(PRCSIP) S J=0 F S J=$O(^PRC(442,XDA,2,J)) Q:'J!($G(PRCSIP)) S K=0 F S K=$O(^PRC(442,XDA,2,J,5,0)) Q:'K!($G(PRCSIP)) S PRCSIP=$P($G(^PRC(442,XDA,2,J,5,K,0)),U)
IP D:'$G(PRCSIP)&'$G(PRCRMPR) IP^PRCSUT ;PRC*5.1*199
I '$G(PRCSIP),'$G(PRCRMPR),$O(^PRC(420,PRC("SITE"),1,PRC("CP"),7,0)) D I Y=0 G IP ;PRC*5.1*199
. K DIR S DIR("A")="** WARNING ** No inventory point selected - Continue anyway",DIR("B")="NO",DIR(0)="Y"
. S DIR("?",1)="The FCP you entered has Inventory points associated with it, but none have been selected."
. S DIR("?")="Press 'Y' to return to the inventory point prompt or 'N' to continue the order without one."
. D ^DIR K DIR
. I $E(X)="^"!(Y=1) W !,"No inventory point was attached.",! Q
. Q
S PC=$P($G(^PRC(442,XDA,23)),"^",8)
S COUNT=$P($G(^PRC(442,XDA,2,0)),"^",4) I +COUNT'=0 D ITEM I $G(X)="#",$G(PRCRMPR)=1 Q
S CDA=$P($G(^PRC(442,XDA,23)),"^",23)
S:$G(PRCHPC)=3 CDA=$P($G(^PRC(442,XDA,13,0)),U,3)
I CDA="" D REC Q:CDA=""
S CCDA=CDA
SET ;set item data and vendor on record
L +^PRCS(410,CDA):15 Q:'$T
;
I VEND'="",$P($G(^PRC(440,VEND,0)),"^")'="SIMPLIFIED" S ^PRCS(410,CDA,2)=$G(^PRC(440,VEND,0))
I $P($G(^PRC(440,+VEND,0)),"^")="SIMPLIFIED" S VEND="SIMPLIFIED" S:$P($G(^PRC(442,XDA,24)),"^",2)'="" VEND=$P($G(^PRC(442,XDA,24)),"^",2) S ^PRCS(410,CDA,2)=VEND
S VEN=$P(^PRCS(410,CDA,2),"^")
S COR=$P($G(^PRC(442,XDA,23)),"^",12),SGRP=$P($G(^PRC(442,XDA,23)),"^",13)
S DA=CDA,DIE="^PRCS(410,",DR="3////4"_";"_"5///"_TDATE_";"_"7////"_SDATE_";"_"15////"_CP_";"_"15.5////"_CCEN_";"_"21////"_TDATE_";"_"12////"_VV D ^DIE
S DR="1////O"_";"_"6.3////"_SERV_";"_"7.5////"_ST_";"_"40////"_DUZ_";"_"68////"_DUZ_";"_"8////"_COR D ^DIE
S DR="46////^S X=LOC"_";"_"47////"_ADATE_";"_"48.1////"_ESTS_";"_"52///"_XDA_";"_"24///"_PCREF D ^DIE
I $G(PRCSIP) S DR="4////^S X=PRCSIP" D ^DIE
I PC="" S PC=9999999
S DR="451////^S X=PC" D ^DIE
I +COUNT'=0 F IT=1:1:COUNT D
.S ^PRCS(410,CDA,"IT",IT,0)=BB(IT)
.I +COUNT1'=0 F J=1:1:COUNT1 D
..S:$D(BB(IT,J)) ^PRCS(410,CDA,"IT",IT,1,J,0)=BB(IT,J)
.I COUNT1="" S ^PRCS(410,CDA,"IT",IT,1,0)="^^1^1^"_TDATE_"^^"
.F LL="AB","B" S ^PRCS(410,CDA,"IT",LL,IT,IT)=""
.I $P(BB(IT),"^",4)'="" S ^PRCS(410,CDA,"IT","AG",$P(BB(IT),"^",4),IT)=""
.S:+COUNT1'=0 ^PRCS(410,CDA,"IT",IT,1,0)="^410.03^"_COUNT1_"^"_COUNT1
I $D(VEN) S ^PRCS(410,"E",$E(VEN,1,30),CDA)=""
S ^PRCS(410,"AQ",1,CDA)="" S:COUNT'="" ^PRCS(410,CDA,"IT",0)="^410.02AI^"_COUNT_"^"_COUNT
L +^PRC(442,XDA):$S(DILOCKTM>15:DILOCKTM,1:15) Q:'$T S $P(^PRC(442,XDA,23),"^",23)=CDA L -^PRC(442,XDA) ;PRC*5.1*181 Set 410 pointer prior to Sort Group query
I '$G(PRCPROST),$G(RPUSE)'=1,$G(COMMENT)'="delivery",$G(PRCHPC)'="" S DA=CDA,DR=49 D ^DIE
L -^PRCS(410,CDA)
L +^PRC(442,XDA):15 Q:'$T S $P(^PRC(442,XDA,23),"^",13)=$P($G(^PRCS(410,CDA,11)),"^") L -^PRC(442,XDA)
S DA=XDA K DIE QUIT
ITEM ;
F IT=1:1:COUNT D
.F J=1,2,3,4,5,6,8 S $P(BB(IT),"^",J)=$P($G(^PRC(442,XDA,2,IT,0)),"^",J)
.S $P(BB(IT),"^",7)=$P($G(^PRC(442,XDA,2,IT,0)),"^",9)
.S COUNT1=$P($G(^PRC(442,XDA,2,IT,1,0)),"^",4) I +COUNT1'=0 F J=1:1:COUNT1 S BB(IT,J)=$G(^PRC(442,XDA,2,IT,1,J,0))
QUIT
REC ;create skeleton 410 record
S:$G(XDA)'="" PRC("CP")=$P($G(^PRC(442,XDA,0)),U,3)
Q:+$G(PRC("CP"))=0
S T(2)="",Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),$P(PRC("CP")," "),1)
S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
D EN1^PRCSUT3 Q:'$D(X) Q:$G(X)="#"&($G(PRCRMPR)=1) S X1=X D EN2^PRCSUT3 Q:$G(DA)="" Q:'$D(X1) S CDA=DA
K X,T(2) QUIT
ESIG ;put ESIG on record, update due-ins
N PRCHOBL ;PRC*171 D.O. auto obligate flags
S NET=$P($G(^PRC(442,PODA,0)),"^",16) L +^PRCS(410,DA):15 Q:'$T F I=1,8 S $P(^PRCS(410,DA,4),"^",I)=NET ;PRC*5.1*192
I $D(PRCHDELV) D SWCHK ;PRC*171 D.O. auto obligate check for EDI and All/Delivery flags on
I $D(PRCHDELV),PRCHOBL=1 S $P(^PRCS(410,DA,4),"^",3)=NET,$P(^PRCS(410,DA,4),"^",4)=$P(^PRCS(410,DA,1),"^") ;PRC*171 auto obligate sets for D.O. flag sets
S:'$D(PRC("CP")) ZIP=$P(^PRC(442,PODA,0),"^",3),PRC("CP")=$P(ZIP," ") Q:PRC("CP")=""
S BAL=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
L -^PRCS(410,DA)
D ERS410^PRC0G(DA_"^A")
S MESSAGE="" D ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
S:'$D(PRC("CP")) ZIP=$P(^PRC(442,PODA,0),"^",3),PRC("CP")=$P(ZIP," ") Q:PRC("CP")=""
D:'$D(PRC("FY")) FY^PRCH442
N KTEMP S KTEMP=X
S AA=PRC("SITE")_"^"_+PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_NET D EBAL^PRCSEZ(AA,"C") I $D(PRCHDELV),PRCHOBL=1 D EBAL^PRCSEZ(AA,"O") ;PRC*171 auto obligate sets for D.O. flag sets
S X=KTEMP
S BAL=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
W !,"Cost of this request: $",$J(X,0,2),!,"Current Control Point Balance: $",$J(BAL,0,2),!
S PRCSN=$G(^PRCS(410,DA,0))
;PRC*5.1*186
I $P(PRCSN,U,4)>1 D
. S X=$P(PRCSN,U,1),DIC="^PRC(443,",DIC(0)="L",DLAYGO=443 D ^DIC K DIC,DLAYGO,X
. S X=$O(^PRCD(442.3,"C",60,0)),PRCHSTS=X
. S DIE="^PRC(443,",DR="1.5////^S X=PRCHSTS" D ^DIE K DR,DIE,PRCHSTS,X
. S $P(^PRC(443,DA,0),U,11)=$P(PRCSN,U,6)
I '$G(PRCHPHAM),$G(PRCHPC)'=1 D EN2^PRCPWI
S PRCSINV=$P(^PRCS(410,DA,0),U,6)
S DIE="^PRC(443,",DR="9///^S X=1;10///^S X=4;11////^S X=PRCSINV;13///^S X=""E"";3.7///^S X=5730;3.5///^S X=1;2////^S X=DUZ"
D ^DIE K DIE,DR
S BAL=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
D ES1^PRCHG
S PRCHSY(0)=^PRC(443,CDA,0) ;After Signature use 443 entry
S PRCHS="",PRCHSY=DA,PRCHSP="" D LST1^PRCHNPO2
S BAL=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
S DA=CDA,DIK="^PRC(443," D ^DIK K DIK
K BAL,ZIP,PRCSN,X,MESSAGE QUIT
SWCHK ;CHECK EDI AND ALL/DEL FLAGS FOR DELIVERY ORDERS ;PRC*171 D.O. auto obligate check for EDI and All/Delivery flags on
N PRCHFUND,PRCEDICK,PRCVEND
S PRCHOBL=0
S PRCVEND=$P($G(^PRC(442,PODA,1)),U) S:PRCVEND'="" PRCEDICK=$P($G(^PRC(440,PRCVEND,3)),U,2)
S PRCHFUND=$P(^PRC(442,PODA,0),U,3) Q:PRCHFUND="" S PRCHFUND=+$P(PRCHFUND," ")
I $P($G(^PRC(442,PODA,23)),U,11)="D"!$D(PRCHDELV) D
. I $P($G(^PRC(420,PRC("SITE"),3)),U,2)'=""!($P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)'="") S PRCHOBL=1 ;PRC*5.1*186
. I $P(^PRC(442,PODA,0),U,2)=26 S PRCHOBL=1
I '$G(PRCHOBL) D
. I ($P($G(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="Y")!($P($G(^PRC(420,PRC("SITE"),3)),U)="Y") S:PRCEDICK="Y" PRCHOBL=1 ;PRC*5.1*186
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH410 9043 printed Sep 23, 2025@19:41:17 Page 2
PRCH410 ;WISC/KMB/DXH/DGL - CREATE 2237 FROM PURCHASE CARD ORDER ; 4/4/00 7:56am
+1 ;;5.1;IFCAP;**123,171,181,186,192,199**;Oct 20, 2000;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; prcsip is package-wide variable for inv pt that may or may not be
+5 ; passed to this routine
+6 ;
+7 ;PRC*5.1*181 Split the update for setting File 442, node 23 piece 23
+8 ; (410 pointer) and piece 13 (sort group) into two sets,
+9 ; 410 pointer before the Sort Group query and Sort Group
+10 ; after. This eliminates a user crashing at Sort Group
+11 ; query and creating 2 410 entries due to missing 410
+12 ; pointer in file 442 that was not set due to Sort
+13 ; Group query failure.
+14 ;
+15 ;PRC*5.1*186 RGB 7/1/2014 Fix for 3 Remedy tickets:
+16 ; INC752542 Fix duplicate entries in file 443 by changing
+17 ; the direct field 1.5 and x-ref 'AC' set to
+18 ; Fileman update of status field.
+19 ; INC952389 Modify logic to insure when All/Delivery switch
+20 ; is set that the DO affects the Running Balance
+21 ; report when auto obligated. Also, modified the
+22 ; EDI check in same area for logic clarity.
+23 ;
+24 ;PRC*5.1*192 RGB 12/16/15 Modify Delivery Order auto obligation file
+25 ; 410 set for net to field #92 to ensure Running Balance
+26 ; reflects the net amount for order.
+27 ;PRC*5.1*199 Check PRCRMPR switch on GUI Prosthetics order filing to
+28 ; skip inventory point selection query for FCPs linked to
+29 ; multiple inventories.
+30 ;
START ;
+1 NEW VV,ST,Y,Z,Z0,Z1,Z2,I,J,CCEN,ESTS,NET,SERV,EMER,COUNT,COUNT1,L,PDUZ,FY,QTR,CP,LOC,ADATE,TDATE,SDATE,LL,PC,PCREF,XDA
+2 NEW SCP,SGRP,COR,VEN,VEND
+3 if '$DATA(DA)
QUIT
if +DA=0
QUIT
SET XDA=DA
+4 SET Z0=$GET(^PRC(442,XDA,0))
SET PRC("SITE")=$PIECE(Z0,"-")
SET CP=$PIECE(Z0,"^",3)
SET SCP=$PIECE(CP," ")
SET PRC("SST")=$PIECE($GET(^PRC(442,XDA,23)),"^",7)
SET PCREF=$PIECE(Z0,"^")
SET PCREF=$PIECE(PCREF,"-",2)
+5 SET TDATE=$$DATE^PRC0C($PIECE($GET(^PRC(442,XDA,1)),"^",15),"I")
SET PRC("FY")=$EXTRACT(TDATE,3,4)
SET PRC("QTR")=$PIECE(TDATE,"^",2)
SET (TDATE,SDATE)=$PIECE($$DATE^PRC0C("T","E"),"^",7)
+6 SET CCEN=$PIECE(Z0,"^",5)
SET ESTS=$PIECE(Z0,"^",13)
SET ADATE=$PIECE(Z0,"^",10)
+7 IF CCEN'=""
SET CCEN=$EXTRACT($PIECE(^PRCD(420.1,CCEN,0),"^"),1,30)
+8 SET Z1=$GET(^PRC(442,XDA,1))
SET (VV,VEND)=$PIECE(Z1,"^")
SET SERV=$PIECE(Z1,"^",2)
SET EMER=$PIECE(Z1,"^",17)
SET LOC=$PIECE(Z1,"^",11)
SET PDUZ=DUZ
+9 SET ST="ST"
if EMER="Y"
SET ST="EM"
+10 SET PRC("CP")=+SCP
+11 ; Kill inventory point if not match FCP
IF $GET(PRCSIP)
IF '$ORDER(^PRC(420,PRC("SITE"),1,PRC("CP"),7,"B",PRCSIP,0))
KILL PRCSIP
+12 IF '$GET(PRCSIP)
SET J=0
FOR
SET J=$ORDER(^PRC(442,XDA,2,J))
if 'J!($GET(PRCSIP))
QUIT
SET K=0
FOR
SET K=$ORDER(^PRC(442,XDA,2,J,5,0))
if 'K!($GET(PRCSIP))
QUIT
SET PRCSIP=$PIECE($GET(^PRC(442,XDA,2,J,5,K,0)),U)
IP ;PRC*5.1*199
if '$GET(PRCSIP)&'$GET(PRCRMPR)
DO IP^PRCSUT
+1 ;PRC*5.1*199
IF '$GET(PRCSIP)
IF '$GET(PRCRMPR)
IF $ORDER(^PRC(420,PRC("SITE"),1,PRC("CP"),7,0))
Begin DoDot:1
+2 KILL DIR
SET DIR("A")="** WARNING ** No inventory point selected - Continue anyway"
SET DIR("B")="NO"
SET DIR(0)="Y"
+3 SET DIR("?",1)="The FCP you entered has Inventory points associated with it, but none have been selected."
+4 SET DIR("?")="Press 'Y' to return to the inventory point prompt or 'N' to continue the order without one."
+5 DO ^DIR
KILL DIR
+6 IF $EXTRACT(X)="^"!(Y=1)
WRITE !,"No inventory point was attached.",!
QUIT
+7 QUIT
End DoDot:1
IF Y=0
GOTO IP
+8 SET PC=$PIECE($GET(^PRC(442,XDA,23)),"^",8)
+9 SET COUNT=$PIECE($GET(^PRC(442,XDA,2,0)),"^",4)
IF +COUNT'=0
DO ITEM
IF $GET(X)="#"
IF $GET(PRCRMPR)=1
QUIT
+10 SET CDA=$PIECE($GET(^PRC(442,XDA,23)),"^",23)
+11 if $GET(PRCHPC)=3
SET CDA=$PIECE($GET(^PRC(442,XDA,13,0)),U,3)
+12 IF CDA=""
DO REC
if CDA=""
QUIT
+13 SET CCDA=CDA
SET ;set item data and vendor on record
+1 LOCK +^PRCS(410,CDA):15
if '$TEST
QUIT
+2 ;
+3 IF VEND'=""
IF $PIECE($GET(^PRC(440,VEND,0)),"^")'="SIMPLIFIED"
SET ^PRCS(410,CDA,2)=$GET(^PRC(440,VEND,0))
+4 IF $PIECE($GET(^PRC(440,+VEND,0)),"^")="SIMPLIFIED"
SET VEND="SIMPLIFIED"
if $PIECE($GET(^PRC(442,XDA,24)),"^",2)'=""
SET VEND=$PIECE($GET(^PRC(442,XDA,24)),"^",2)
SET ^PRCS(410,CDA,2)=VEND
+5 SET VEN=$PIECE(^PRCS(410,CDA,2),"^")
+6 SET COR=$PIECE($GET(^PRC(442,XDA,23)),"^",12)
SET SGRP=$PIECE($GET(^PRC(442,XDA,23)),"^",13)
+7 SET DA=CDA
SET DIE="^PRCS(410,"
SET DR="3////4"_";"_"5///"_TDATE_";"_"7////"_SDATE_";"_"15////"_CP_";"_"15.5////"_CCEN_";"_"21////"_TDATE_";"_"12////"_VV
DO ^DIE
+8 SET DR="1////O"_";"_"6.3////"_SERV_";"_"7.5////"_ST_";"_"40////"_DUZ_";"_"68////"_DUZ_";"_"8////"_COR
DO ^DIE
+9 SET DR="46////^S X=LOC"_";"_"47////"_ADATE_";"_"48.1////"_ESTS_";"_"52///"_XDA_";"_"24///"_PCREF
DO ^DIE
+10 IF $GET(PRCSIP)
SET DR="4////^S X=PRCSIP"
DO ^DIE
+11 IF PC=""
SET PC=9999999
+12 SET DR="451////^S X=PC"
DO ^DIE
+13 IF +COUNT'=0
FOR IT=1:1:COUNT
Begin DoDot:1
+14 SET ^PRCS(410,CDA,"IT",IT,0)=BB(IT)
+15 IF +COUNT1'=0
FOR J=1:1:COUNT1
Begin DoDot:2
+16 if $DATA(BB(IT,J))
SET ^PRCS(410,CDA,"IT",IT,1,J,0)=BB(IT,J)
End DoDot:2
+17 IF COUNT1=""
SET ^PRCS(410,CDA,"IT",IT,1,0)="^^1^1^"_TDATE_"^^"
+18 FOR LL="AB","B"
SET ^PRCS(410,CDA,"IT",LL,IT,IT)=""
+19 IF $PIECE(BB(IT),"^",4)'=""
SET ^PRCS(410,CDA,"IT","AG",$PIECE(BB(IT),"^",4),IT)=""
+20 if +COUNT1'=0
SET ^PRCS(410,CDA,"IT",IT,1,0)="^410.03^"_COUNT1_"^"_COUNT1
End DoDot:1
+21 IF $DATA(VEN)
SET ^PRCS(410,"E",$EXTRACT(VEN,1,30),CDA)=""
+22 SET ^PRCS(410,"AQ",1,CDA)=""
if COUNT'=""
SET ^PRCS(410,CDA,"IT",0)="^410.02AI^"_COUNT_"^"_COUNT
+23 ;PRC*5.1*181 Set 410 pointer prior to Sort Group query
LOCK +^PRC(442,XDA):$SELECT(DILOCKTM>15:DILOCKTM,1:15)
if '$TEST
QUIT
SET $PIECE(^PRC(442,XDA,23),"^",23)=CDA
LOCK -^PRC(442,XDA)
+24 IF '$GET(PRCPROST)
IF $GET(RPUSE)'=1
IF $GET(COMMENT)'="delivery"
IF $GET(PRCHPC)'=""
SET DA=CDA
SET DR=49
DO ^DIE
+25 LOCK -^PRCS(410,CDA)
+26 LOCK +^PRC(442,XDA):15
if '$TEST
QUIT
SET $PIECE(^PRC(442,XDA,23),"^",13)=$PIECE($GET(^PRCS(410,CDA,11)),"^")
LOCK -^PRC(442,XDA)
+27 SET DA=XDA
KILL DIE
QUIT
ITEM ;
+1 FOR IT=1:1:COUNT
Begin DoDot:1
+2 FOR J=1,2,3,4,5,6,8
SET $PIECE(BB(IT),"^",J)=$PIECE($GET(^PRC(442,XDA,2,IT,0)),"^",J)
+3 SET $PIECE(BB(IT),"^",7)=$PIECE($GET(^PRC(442,XDA,2,IT,0)),"^",9)
+4 SET COUNT1=$PIECE($GET(^PRC(442,XDA,2,IT,1,0)),"^",4)
IF +COUNT1'=0
FOR J=1:1:COUNT1
SET BB(IT,J)=$GET(^PRC(442,XDA,2,IT,1,J,0))
End DoDot:1
+5 QUIT
REC ;create skeleton 410 record
+1 if $GET(XDA)'=""
SET PRC("CP")=$PIECE($GET(^PRC(442,XDA,0)),U,3)
+2 if +$GET(PRC("CP"))=0
QUIT
+3 SET T(2)=""
SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+4 SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),$PIECE(PRC("CP")," "),1)
+5 SET X=$PIECE(Z,"-",1,2)_"-"_$PIECE(PRC("CP")," ")
+6 DO EN1^PRCSUT3
if '$DATA(X)
QUIT
if $GET(X)="#"&($GET(PRCRMPR)=1)
QUIT
SET X1=X
DO EN2^PRCSUT3
if $GET(DA)=""
QUIT
if '$DATA(X1)
QUIT
SET CDA=DA
+7 KILL X,T(2)
QUIT
ESIG ;put ESIG on record, update due-ins
+1 ;PRC*171 D.O. auto obligate flags
NEW PRCHOBL
+2 ;PRC*5.1*192
SET NET=$PIECE($GET(^PRC(442,PODA,0)),"^",16)
LOCK +^PRCS(410,DA):15
if '$TEST
QUIT
FOR I=1,8
SET $PIECE(^PRCS(410,DA,4),"^",I)=NET
+3 ;PRC*171 D.O. auto obligate check for EDI and All/Delivery flags on
IF $DATA(PRCHDELV)
DO SWCHK
+4 ;PRC*171 auto obligate sets for D.O. flag sets
IF $DATA(PRCHDELV)
IF PRCHOBL=1
SET $PIECE(^PRCS(410,DA,4),"^",3)=NET
SET $PIECE(^PRCS(410,DA,4),"^",4)=$PIECE(^PRCS(410,DA,1),"^")
+5 if '$DATA(PRC("CP"))
SET ZIP=$PIECE(^PRC(442,PODA,0),"^",3)
SET PRC("CP")=$PIECE(ZIP," ")
if PRC("CP")=""
QUIT
+6 SET BAL=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
+7 LOCK -^PRCS(410,DA)
+8 DO ERS410^PRC0G(DA_"^A")
+9 SET MESSAGE=""
DO ENCODE^PRCSC1(DA,DUZ,.MESSAGE)
+10 if '$DATA(PRC("CP"))
SET ZIP=$PIECE(^PRC(442,PODA,0),"^",3)
SET PRC("CP")=$PIECE(ZIP," ")
if PRC("CP")=""
QUIT
+11 if '$DATA(PRC("FY"))
DO FY^PRCH442
+12 NEW KTEMP
SET KTEMP=X
+13 ;PRC*171 auto obligate sets for D.O. flag sets
SET AA=PRC("SITE")_"^"_+PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_NET
DO EBAL^PRCSEZ(AA,"C")
IF $DATA(PRCHDELV)
IF PRCHOBL=1
DO EBAL^PRCSEZ(AA,"O")
+14 SET X=KTEMP
+15 SET BAL=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
+16 WRITE !,"Cost of this request: $",$JUSTIFY(X,0,2),!,"Current Control Point Balance: $",$JUSTIFY(BAL,0,2),!
+17 SET PRCSN=$GET(^PRCS(410,DA,0))
+18 ;PRC*5.1*186
+19 IF $PIECE(PRCSN,U,4)>1
Begin DoDot:1
+20 SET X=$PIECE(PRCSN,U,1)
SET DIC="^PRC(443,"
SET DIC(0)="L"
SET DLAYGO=443
DO ^DIC
KILL DIC,DLAYGO,X
+21 SET X=$ORDER(^PRCD(442.3,"C",60,0))
SET PRCHSTS=X
+22 SET DIE="^PRC(443,"
SET DR="1.5////^S X=PRCHSTS"
DO ^DIE
KILL DR,DIE,PRCHSTS,X
+23 SET $PIECE(^PRC(443,DA,0),U,11)=$PIECE(PRCSN,U,6)
End DoDot:1
+24 IF '$GET(PRCHPHAM)
IF $GET(PRCHPC)'=1
DO EN2^PRCPWI
+25 SET PRCSINV=$PIECE(^PRCS(410,DA,0),U,6)
+26 SET DIE="^PRC(443,"
SET DR="9///^S X=1;10///^S X=4;11////^S X=PRCSINV;13///^S X=""E"";3.7///^S X=5730;3.5///^S X=1;2////^S X=DUZ"
+27 DO ^DIE
KILL DIE,DR
+28 SET BAL=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
+29 DO ES1^PRCHG
+30 ;After Signature use 443 entry
SET PRCHSY(0)=^PRC(443,CDA,0)
+31 SET PRCHS=""
SET PRCHSY=DA
SET PRCHSP=""
DO LST1^PRCHNPO2
+32 SET BAL=$PIECE($GET(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",PRC("QTR")+1)
+33 SET DA=CDA
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+34 KILL BAL,ZIP,PRCSN,X,MESSAGE
QUIT
SWCHK ;CHECK EDI AND ALL/DEL FLAGS FOR DELIVERY ORDERS ;PRC*171 D.O. auto obligate check for EDI and All/Delivery flags on
+1 NEW PRCHFUND,PRCEDICK,PRCVEND
+2 SET PRCHOBL=0
+3 SET PRCVEND=$PIECE($GET(^PRC(442,PODA,1)),U)
if PRCVEND'=""
SET PRCEDICK=$PIECE($GET(^PRC(440,PRCVEND,3)),U,2)
+4 SET PRCHFUND=$PIECE(^PRC(442,PODA,0),U,3)
if PRCHFUND=""
QUIT
SET PRCHFUND=+$PIECE(PRCHFUND," ")
+5 IF $PIECE($GET(^PRC(442,PODA,23)),U,11)="D"!$DATA(PRCHDELV)
Begin DoDot:1
+6 ;PRC*5.1*186
IF $PIECE($GET(^PRC(420,PRC("SITE"),3)),U,2)'=""!($PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U,2)'="")
SET PRCHOBL=1
+7 IF $PIECE(^PRC(442,PODA,0),U,2)=26
SET PRCHOBL=1
End DoDot:1
+8 IF '$GET(PRCHOBL)
Begin DoDot:1
+9 ;PRC*5.1*186
IF ($PIECE($GET(^PRC(420,PRC("SITE"),1,PRCHFUND,6)),U)="Y")!($PIECE($GET(^PRC(420,PRC("SITE"),3)),U)="Y")
if PRCEDICK="Y"
SET PRCHOBL=1
End DoDot:1
+10 QUIT
