- 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 Mar 13, 2025@21:17:30 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
