PRCH7PA1 ;Hines IOFO/RVD - PROS IFCAP GUI ADD PO ;8/13/03 07:58
;;5.1;IFCAP;**68,122**;Oct 20, 2000;Build 1
;Per VHA Directive 10-93-142, this routine should not be modified.
;
;This routine will take the next Common Numbering Series and update
;file 442.6 for the next number. It will also create an entry in
;file 442 (PO) to be used in obligation.
;Line label AD1 is to be used for MUMPS entry point.
;Line label ADDPO is an entry point for Remote Procedure Call.
;
; DUZ - User
; PRCSITE - Station Number IEN
; RMPRSITE - IEN of 669.9
; PRCHXXX - IEN of 440.5 Purchase Card
; PRCHVEN - IEN of 440 Vendor
; PRC4426 - Common Numbering Series
; RESULTS(0) = IEN of 442 ^ PO NUMBER
Q
AD1(DUZ,PRCSITE,RMPRSITE,PRCHXXX,PRCHVEN,PRC4425) G AD2
;
ADDPO(RESULTS,DUZ,PRCSITE,RMPRSITE,PRCHXXX,PRCHVEN,PRC4426) ;create the next PAT number.
;
AD2 ;
Q:'$D(PRCSITE)
EN1 ;
I '$D(^PRC(411,PRCSITE,0)) S RESULTS(0)="^IFCAP Station Not Defined in file # 411." Q
I PRC4426="" S RESULTS(0)="Common Numbering Series was not passed see your Supervisor." Q
L +^PRC(442.6,PRC4426,0):1 I '$T S RESULTS(0)="^Unable to Access IFCAP file (#442.6), Try Later." Q
D GETS^DIQ(442.6,PRC4426,".01;3;2;1","","PRCN")
S PRCLO=$G(PRCN(442.6,PRC4426_",",1))
S PRCNEXT=$G(PRCN(442.6,PRC4426_",",3))
S PRCSTPO=$G(PRCN(442.6,PRC4426_",",.01))
S PRCPO=$P(PRCSTPO,"-",2)
S PRCUPBO=$G(PRCN(442.6,PRC4426_",",2))
I PRCNEXT="" S RESULTS(0)="^The Common Numbering Series is Null."
S PRCNEXT=PRCNEXT+1
I PRCNEXT>PRCUPBO S RESULTS(0)="^The Common Numbering Series Exceeds the limit, please use a different Common Numbering Series." L -^PRC(442.6,PRC4426,0) Q
;calculate PO to be 6 places.
D NUM
S PRCNEXT=+PRCNEXT
S DIE="^PRC(442.6,"
S DA=PRC4426
S DR="3////^S X=PRCNEXT"
D ^DIE
L -^PRC(442.6,PRC4426,0)
K DIE,DA,DR
;
I $D(^PRC(442,"B",PRCROBL)) S RESULTS(0)="^P.O. "_PRCROBL_" already exist, please use a different PO number." Q
;
PO ;PO must be defined in PRCROBL.
;Create a PO entry in 442.
S X=PRCROBL
K DIC("S") S PRCHNEW="",DIC="^PRC(442,",DLAYGO=442,DIC(0)="L" D ^DIC
I +(Y)'>0 S RESULTS(0)="^UNABLE to Create a Purchase Order, Please Try Later." Q
S (DA,PRCHPO,PRC442)=+Y,%DT="T",X="NOW" D ^%DT S $P(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
S (X,Y)=1,PRCHX=X,DIE="^PRC(442,",DR=".5////1" D ^DIE K DIE,DR
S $P(^PRC(442,PRCHPO,1),U,10)=DUZ
S PRCA=PRCSITE_"^"_PRCHVEN
S RESULTS(0)=PRCHPO_"^"_PRCROBL
S PRCRI(420)=+PRCA,PRC("SITE")=$P(PRCA,"^"),PRCRI(440)=$P(PRCA,"^",2)
S X="" S:$D(PRC("SITE")) PRC("PARAM")=^PRC(411,PRC("SITE"),0)
S (PRCPROST,PRCHPC)=1
S (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))="",PRCHN("SFC")=+$P(^PRC(442,DA,0),U,19),PRCHN("FOB")=$S($D(^(1)):$P(^(1),U,6),1:""),PRCHN(12)=$S($D(^PRC(442,DA,12)):^(12),1:"")
S PRCHPONO=$P(^PRC(442,DA,0),U,1),PRCHSTN=$P(PRCHPONO,"-") S PRCHIEN=DA
S PRCX=$O(^PRC(411,PRC("SITE"),1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,PRC("SITE"),1,PRCX,0)),U) K PRCX
S DA=PRCHPO
D DOCID
S PRC31=PRCSITE
S DA=PRCHPO
S DIE="^PRC(442,"
S PRC48="S"
S PRC54="N"
S PRC5="SIMPLIFIED"
S PRC1="T"
S PRCHP=^PRC(440.5,PRCHXXX,0),PRCHFCP=$P(PRCHP,U,2),PRCHCC=$P(PRCHP,U,3),PRCHBOC1=$P(PRCHP,U,4),PRCHDLOC=$P(PRCHP,U,7),PRCHCD=$P(PRCHP,U),PRCHCDNO=PRCHXXX,PRCHHLDR=$P(PRCHP,U,8)
TST S DR="16////^S X=DUZ;56////^S X=DUZ;.02///^S X=25;48///^S X=PRC48;63///^S X=1;54///^S X=PRC54;31////^S X=PRC31;S SUB=X" D ^DIE
I $D(SUB) S PRCX=$O(^PRC(411,SUB,1,0)) S:$G(PRCX)]"" PRCY=$P($G(^PRC(411,SUB,1,PRCX,0)),U) K PRCX
S DR="46////^S X=PRCHXXX;61////^S X=PRCHHLDR" D ^DIE
S PRCHCDNO=$P($G(^PRC(442,DA,23)),U,8)
S DR="55///^S X=PRCHCD;.1///^S X=PRC1;53////^S X=PRCHVEN;5////^S X=PRCHVEN" D ^DIE
S TDATE=$$DATE^PRC0C($P($G(^PRC(442,DA,1)),"^",15),"I"),PRC("FY")=$E(TDATE,3,4)
S PRCBBFY=$$BBFY^PRCSUT(PRCSITE,PRC("FY"),PRCHFCP,1),PRC("BBFY")=PRCBBFY
S DR="1///^S X=PRCHFCP" D ^DIE
S PRCHN("SFC")=$P(^PRC(442,DA,0),U,19)
S DR="26///^S X=PRCBBFY;2///^S X=PRCHCC;5.4///^S X=PRC5"
D ^DIE
S PRCPROST=1.9
L -^PRC(442,PRC442)
K DIE,DA,DLAYGO,DR,PRCBBFY,PRCHCC,PRCHCD,PRCHCDNO,PRCHDLOC,PRCHFCP,PRCHHLDR,PRCHIEN,PRCHNEW,PRCHP,PRCHPONO,PRCHSTN,PRCHX,PRCLO,PRCN,PRCNEXT,PRCNEXT1
K PRCPO,PRCY,PRX,PRZ,RMPRCIEN,RMPRFCP,X,PRCSTPO,PRCUPBO,PRC1,PRC442,PRC4426,PRC5,PRC54,PRC48,PRC31,SUB,TDATE,PRCROBL
Q
;
NUM ;check next number and set the PO to 6 places.
;
S PRCX="",$P(PRCX,"0",6)="",PRCNEXT1=PRCX_PRCNEXT
S PRCNEXT=$E(PRCNEXT1,$L(PRCNEXT)+$L(PRCPO),$L(PRCNEXT1))
S PRCROBL=PRCSTPO_PRCNEXT
Q
;
DOCID S PRZ=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2) Q:$L(PRZ)'=6 F I=1:1:6 S PRX=$E(PRZ,I,I) Q:+PRX=PRX
I +PRX=PRX S $P(^PRC(442,PRCHPO,18),"^",3)=$S(I=1:$E(PRZ,2,6),1:$E(PRZ,1,I-1)_$E(PRZ,I+1,6))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH7PA1 4755 printed Sep 23, 2025@19:41:31 Page 2
PRCH7PA1 ;Hines IOFO/RVD - PROS IFCAP GUI ADD PO ;8/13/03 07:58
+1 ;;5.1;IFCAP;**68,122**;Oct 20, 2000;Build 1
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;This routine will take the next Common Numbering Series and update
+5 ;file 442.6 for the next number. It will also create an entry in
+6 ;file 442 (PO) to be used in obligation.
+7 ;Line label AD1 is to be used for MUMPS entry point.
+8 ;Line label ADDPO is an entry point for Remote Procedure Call.
+9 ;
+10 ; DUZ - User
+11 ; PRCSITE - Station Number IEN
+12 ; RMPRSITE - IEN of 669.9
+13 ; PRCHXXX - IEN of 440.5 Purchase Card
+14 ; PRCHVEN - IEN of 440 Vendor
+15 ; PRC4426 - Common Numbering Series
+16 ; RESULTS(0) = IEN of 442 ^ PO NUMBER
+17 QUIT
AD1(DUZ,PRCSITE,RMPRSITE,PRCHXXX,PRCHVEN,PRC4425) GOTO AD2
+1 ;
ADDPO(RESULTS,DUZ,PRCSITE,RMPRSITE,PRCHXXX,PRCHVEN,PRC4426) ;create the next PAT number.
+1 ;
AD2 ;
+1 if '$DATA(PRCSITE)
QUIT
EN1 ;
+1 IF '$DATA(^PRC(411,PRCSITE,0))
SET RESULTS(0)="^IFCAP Station Not Defined in file # 411."
QUIT
+2 IF PRC4426=""
SET RESULTS(0)="Common Numbering Series was not passed see your Supervisor."
QUIT
+3 LOCK +^PRC(442.6,PRC4426,0):1
IF '$TEST
SET RESULTS(0)="^Unable to Access IFCAP file (#442.6), Try Later."
QUIT
+4 DO GETS^DIQ(442.6,PRC4426,".01;3;2;1","","PRCN")
+5 SET PRCLO=$GET(PRCN(442.6,PRC4426_",",1))
+6 SET PRCNEXT=$GET(PRCN(442.6,PRC4426_",",3))
+7 SET PRCSTPO=$GET(PRCN(442.6,PRC4426_",",.01))
+8 SET PRCPO=$PIECE(PRCSTPO,"-",2)
+9 SET PRCUPBO=$GET(PRCN(442.6,PRC4426_",",2))
+10 IF PRCNEXT=""
SET RESULTS(0)="^The Common Numbering Series is Null."
+11 SET PRCNEXT=PRCNEXT+1
+12 IF PRCNEXT>PRCUPBO
SET RESULTS(0)="^The Common Numbering Series Exceeds the limit, please use a different Common Numbering Series."
LOCK -^PRC(442.6,PRC4426,0)
QUIT
+13 ;calculate PO to be 6 places.
+14 DO NUM
+15 SET PRCNEXT=+PRCNEXT
+16 SET DIE="^PRC(442.6,"
+17 SET DA=PRC4426
+18 SET DR="3////^S X=PRCNEXT"
+19 DO ^DIE
+20 LOCK -^PRC(442.6,PRC4426,0)
+21 KILL DIE,DA,DR
+22 ;
+23 IF $DATA(^PRC(442,"B",PRCROBL))
SET RESULTS(0)="^P.O. "_PRCROBL_" already exist, please use a different PO number."
QUIT
+24 ;
PO ;PO must be defined in PRCROBL.
+1 ;Create a PO entry in 442.
+2 SET X=PRCROBL
+3 KILL DIC("S")
SET PRCHNEW=""
SET DIC="^PRC(442,"
SET DLAYGO=442
SET DIC(0)="L"
DO ^DIC
+4 IF +(Y)'>0
SET RESULTS(0)="^UNABLE to Create a Purchase Order, Please Try Later."
QUIT
+5 SET (DA,PRCHPO,PRC442)=+Y
SET %DT="T"
SET X="NOW"
DO ^%DT
SET $PIECE(^PRC(442,PRCHPO,12),U,4,5)=DUZ_U_Y
+6 SET (X,Y)=1
SET PRCHX=X
SET DIE="^PRC(442,"
SET DR=".5////1"
DO ^DIE
KILL DIE,DR
+7 SET $PIECE(^PRC(442,PRCHPO,1),U,10)=DUZ
+8 SET PRCA=PRCSITE_"^"_PRCHVEN
+9 SET RESULTS(0)=PRCHPO_"^"_PRCROBL
+10 SET PRCRI(420)=+PRCA
SET PRC("SITE")=$PIECE(PRCA,"^")
SET PRCRI(440)=$PIECE(PRCA,"^",2)
+11 SET X=""
if $DATA(PRC("SITE"))
SET PRC("PARAM")=^PRC(411,PRC("SITE"),0)
+12 SET (PRCPROST,PRCHPC)=1
+13 SET (PRCHN("SVC"),PRCHN("CC"),PRCHN("SC"),PRCHN("INV"))=""
SET PRCHN("SFC")=+$PIECE(^PRC(442,DA,0),U,19)
SET PRCHN("FOB")=$SELECT($DATA(^(1)):$PIECE(^(1),U,6),1:"")
SET PRCHN(12)=$SELECT($DATA(^PRC(442,DA,12)):^(12),1:"")
+14 SET PRCHPONO=$PIECE(^PRC(442,DA,0),U,1)
SET PRCHSTN=$PIECE(PRCHPONO,"-")
SET PRCHIEN=DA
+15 SET PRCX=$ORDER(^PRC(411,PRC("SITE"),1,0))
if $GET(PRCX)]""
SET PRCY=$PIECE($GET(^PRC(411,PRC("SITE"),1,PRCX,0)),U)
KILL PRCX
+16 SET DA=PRCHPO
+17 DO DOCID
+18 SET PRC31=PRCSITE
+19 SET DA=PRCHPO
+20 SET DIE="^PRC(442,"
+21 SET PRC48="S"
+22 SET PRC54="N"
+23 SET PRC5="SIMPLIFIED"
+24 SET PRC1="T"
+25 SET PRCHP=^PRC(440.5,PRCHXXX,0)
SET PRCHFCP=$PIECE(PRCHP,U,2)
SET PRCHCC=$PIECE(PRCHP,U,3)
SET PRCHBOC1=$PIECE(PRCHP,U,4)
SET PRCHDLOC=$PIECE(PRCHP,U,7)
SET PRCHCD=$PIECE(PRCHP,U)
SET PRCHCDNO=PRCHXXX
SET PRCHHLDR=$PIECE(PRCHP,U,8)
TST SET DR="16////^S X=DUZ;56////^S X=DUZ;.02///^S X=25;48///^S X=PRC48;63///^S X=1;54///^S X=PRC54;31////^S X=PRC31;S SUB=X"
DO ^DIE
+1 IF $DATA(SUB)
SET PRCX=$ORDER(^PRC(411,SUB,1,0))
if $GET(PRCX)]""
SET PRCY=$PIECE($GET(^PRC(411,SUB,1,PRCX,0)),U)
KILL PRCX
+2 SET DR="46////^S X=PRCHXXX;61////^S X=PRCHHLDR"
DO ^DIE
+3 SET PRCHCDNO=$PIECE($GET(^PRC(442,DA,23)),U,8)
+4 SET DR="55///^S X=PRCHCD;.1///^S X=PRC1;53////^S X=PRCHVEN;5////^S X=PRCHVEN"
DO ^DIE
+5 SET TDATE=$$DATE^PRC0C($PIECE($GET(^PRC(442,DA,1)),"^",15),"I")
SET PRC("FY")=$EXTRACT(TDATE,3,4)
+6 SET PRCBBFY=$$BBFY^PRCSUT(PRCSITE,PRC("FY"),PRCHFCP,1)
SET PRC("BBFY")=PRCBBFY
+7 SET DR="1///^S X=PRCHFCP"
DO ^DIE
+8 SET PRCHN("SFC")=$PIECE(^PRC(442,DA,0),U,19)
+9 SET DR="26///^S X=PRCBBFY;2///^S X=PRCHCC;5.4///^S X=PRC5"
+10 DO ^DIE
+11 SET PRCPROST=1.9
+12 LOCK -^PRC(442,PRC442)
+13 KILL DIE,DA,DLAYGO,DR,PRCBBFY,PRCHCC,PRCHCD,PRCHCDNO,PRCHDLOC,PRCHFCP,PRCHHLDR,PRCHIEN,PRCHNEW,PRCHP,PRCHPONO,PRCHSTN,PRCHX,PRCLO,PRCN,PRCNEXT,PRCNEXT1
+14 KILL PRCPO,PRCY,PRX,PRZ,RMPRCIEN,RMPRFCP,X,PRCSTPO,PRCUPBO,PRC1,PRC442,PRC4426,PRC5,PRC54,PRC48,PRC31,SUB,TDATE,PRCROBL
+15 QUIT
+16 ;
NUM ;check next number and set the PO to 6 places.
+1 ;
+2 SET PRCX=""
SET $PIECE(PRCX,"0",6)=""
SET PRCNEXT1=PRCX_PRCNEXT
+3 SET PRCNEXT=$EXTRACT(PRCNEXT1,$LENGTH(PRCNEXT)+$LENGTH(PRCPO),$LENGTH(PRCNEXT1))
+4 SET PRCROBL=PRCSTPO_PRCNEXT
+5 QUIT
+6 ;
DOCID SET PRZ=$PIECE($PIECE(^PRC(442,PRCHPO,0),U,1),"-",2)
if $LENGTH(PRZ)'=6
QUIT
FOR I=1:1:6
SET PRX=$EXTRACT(PRZ,I,I)
if +PRX=PRX
QUIT
+1 IF +PRX=PRX
SET $PIECE(^PRC(442,PRCHPO,18),"^",3)=$SELECT(I=1:$EXTRACT(PRZ,2,6),1:$EXTRACT(PRZ,1,I-1)_$EXTRACT(PRZ,I+1,6))
+2 QUIT
