PRCPAGS2 ;WISC/RFJ-autogen secondary order (build, reports) ;01 Dec 92
;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
CONT ; continue auto-generation
N D,DESCNSN,DISTDA,GNM,ITEMDA,PRCPERR,PRCPNOT,PRCPNOV,PRCPORD,VDA,VNM,X
;
D OPTIONAL^PRCPAGU1
;
I $O(^TMP($J,"PRCPAG","OK",""))="" D
. W:'$D(PRCPSCHE) !!,"NO ITEMS HAVE BEEN ORDERED !!"
. S:$D(PRCPSCHE) $P(PRCPSCHE,"^",2)=3
E W !!,"<<< Building distribution orders ..." D
. S VNM="" F S VNM=$O(^TMP($J,"PRCPAG","OK",VNM)) Q:VNM="" S VDA=0 F S VDA=$O(^TMP($J,"PRCPAG","OK",VNM,VDA)) Q:'VDA D
. . W !?5,VNM
. . D NEWORDER^PRCPOPUS(VDA) I '$G(X) D Q
. . . W ?25,"Order NOT built, could not get next order number"
. . . S:$D(PRCPSCHE) $P(PRCPSCHE,"^",2)=1
. . S DISTDA=+$$ADDNEW^PRCPOPUS(X,VDA,PRCP("I"))
. . S PRCPORD=$G(^PRCP(445.3,DISTDA,0)) I PRCPORD="" D Q
. . . W ?25,"Order NOT built, could not add a new order"
. . . S:$D(PRCPSCHE) $P(PRCPSCHE,"^",2)=2
. . W ?25,"Order number: ",+PRCPORD
. . S ^TMP($J,"PRCPAG","VO",VDA)=+PRCPORD I $G(PRCPFBAR) S ^TMP($J,"PRCPBAL3",DISTDA)=""
. . S GNM="" F S GNM=$O(^TMP($J,"PRCPAG","OK",VNM,VDA,GNM)) Q:GNM="" S DESCNSN="" F S DESCNSN=$O(^TMP($J,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN)) Q:DESCNSN="" D
. . . S X="",ITEMDA=0 F %=0:1 S ITEMDA=$O(^TMP($J,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN,ITEMDA)) Q:'ITEMDA S X=ITEMDA,D=^(ITEMDA) D
. . . . S ^PRCP(445.3,DISTDA,1,ITEMDA,0)=ITEMDA_"^"_$P(D,"^",11)_"^"_$P(D,"^",14)
. . . . S ^PRCP(445.3,DISTDA,1,"B",ITEMDA,ITEMDA)=""
. . . S ^PRCP(445.3,DISTDA,1,0)="^445.37PIA^"_X_"^"_%
;
; prcpfbar is set by the barcode upload programs to prevent printing
; the reports
I '$G(PRCPFBAR),'$D(PRCPSCHE) D REPORTS^PRCPAGU1 K ^TMP($J,"PRCPBAL3")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPAGS2 1895 printed Sep 23, 2025@19:48:47 Page 2
PRCPAGS2 ;WISC/RFJ-autogen secondary order (build, reports) ;01 Dec 92
+1 ;;5.1;IFCAP;**1**;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 QUIT
+4 ;
+5 ;
CONT ; continue auto-generation
+1 NEW D,DESCNSN,DISTDA,GNM,ITEMDA,PRCPERR,PRCPNOT,PRCPNOV,PRCPORD,VDA,VNM,X
+2 ;
+3 DO OPTIONAL^PRCPAGU1
+4 ;
+5 IF $ORDER(^TMP($JOB,"PRCPAG","OK",""))=""
Begin DoDot:1
+6 if '$DATA(PRCPSCHE)
WRITE !!,"NO ITEMS HAVE BEEN ORDERED !!"
+7 if $DATA(PRCPSCHE)
SET $PIECE(PRCPSCHE,"^",2)=3
End DoDot:1
+8 IF '$TEST
WRITE !!,"<<< Building distribution orders ..."
Begin DoDot:1
+9 SET VNM=""
FOR
SET VNM=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM))
if VNM=""
QUIT
SET VDA=0
FOR
SET VDA=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA))
if 'VDA
QUIT
Begin DoDot:2
+10 WRITE !?5,VNM
+11 DO NEWORDER^PRCPOPUS(VDA)
IF '$GET(X)
Begin DoDot:3
+12 WRITE ?25,"Order NOT built, could not get next order number"
+13 if $DATA(PRCPSCHE)
SET $PIECE(PRCPSCHE,"^",2)=1
End DoDot:3
QUIT
+14 SET DISTDA=+$$ADDNEW^PRCPOPUS(X,VDA,PRCP("I"))
+15 SET PRCPORD=$GET(^PRCP(445.3,DISTDA,0))
IF PRCPORD=""
Begin DoDot:3
+16 WRITE ?25,"Order NOT built, could not add a new order"
+17 if $DATA(PRCPSCHE)
SET $PIECE(PRCPSCHE,"^",2)=2
End DoDot:3
QUIT
+18 WRITE ?25,"Order number: ",+PRCPORD
+19 SET ^TMP($JOB,"PRCPAG","VO",VDA)=+PRCPORD
IF $GET(PRCPFBAR)
SET ^TMP($JOB,"PRCPBAL3",DISTDA)=""
+20 SET GNM=""
FOR
SET GNM=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA,GNM))
if GNM=""
QUIT
SET DESCNSN=""
FOR
SET DESCNSN=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN))
if DESCNSN=""
QUIT
Begin DoDot:3
+21 SET X=""
SET ITEMDA=0
FOR %=0:1
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPAG","OK",VNM,VDA,GNM,DESCNSN,ITEMDA))
if 'ITEMDA
QUIT
SET X=ITEMDA
SET D=^(ITEMDA)
Begin DoDot:4
+22 SET ^PRCP(445.3,DISTDA,1,ITEMDA,0)=ITEMDA_"^"_$PIECE(D,"^",11)_"^"_$PIECE(D,"^",14)
+23 SET ^PRCP(445.3,DISTDA,1,"B",ITEMDA,ITEMDA)=""
End DoDot:4
+24 SET ^PRCP(445.3,DISTDA,1,0)="^445.37PIA^"_X_"^"_%
End DoDot:3
End DoDot:2
End DoDot:1
+25 ;
+26 ; prcpfbar is set by the barcode upload programs to prevent printing
+27 ; the reports
+28 IF '$GET(PRCPFBAR)
IF '$DATA(PRCPSCHE)
DO REPORTS^PRCPAGU1
KILL ^TMP($JOB,"PRCPBAL3")
+29 QUIT
