- PRCPRIB0 ;WISC/RFJ-issue book request form(called from ifcap only) ;22 Dec 92
- ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- DQ ; called from ifcap (not prcp*) to print issue book request
- ; form
- ; prcprib = internal entry to 410
- N %,%H,%I,CLASS,D,DATA,DEPART,DESCNSN,DESCR,ITEMDA,ITEMDATA,LINEDA,LINEITEM,MULTIPLE,NOW,NOWDT,NSN,P,PAGE,PRCPDA,PRCPFLAG,PRIMARY,PRIMDATA,SCREEN,SORT,STAR,TEMPLVL,TOTAL,TRANDAT1,TRANDAT3,TRANDAT7,TRANDAT9,TRANDATA,USER,VENDOR,X,Y
- S PRCPDA=+$G(PRCPRIB),TRANDATA=$G(^PRCS(410,PRCPDA,0)) I TRANDATA="" W !!,"ERROR -- NUMBER '",PRCPDA,"' NOT IN CONTROL POINT ACTIVITY FILE" Q
- S PRIMARY=+$P(TRANDATA,"^",6),PRIMDATA=$G(^PRCP(445,PRIMARY,0))
- S SORT=$P($G(^PRC(411,+TRANDATA,0)),"^",21) I $TR($P(PRIMDATA,"^",10),"S")'="" S SORT=$P(PRIMDATA,"^",10)
- S:SORT="" SORT="N"
- ;
- S TRANDAT1=$G(^PRCS(410,PRCPDA,1)),%=$P(TRANDAT1,"^",3),$P(TRANDAT1,"^",3)=$S(%="ST":"STANDARD",%="EM":"EMERGENCY",%="SP":"SPECIAL",1:"<< NOT SPECIFIED >>")
- S Y=$P(TRANDAT1,"^") D DD^%DT S $P(TRANDAT1,"^")=Y,Y=$P(TRANDAT1,"^",4) D DD^%DT S $P(TRANDAT1,"^",4)=Y
- S CLASS=$P($G(^PRCS(410.2,+$P(TRANDAT1,"^",5),0)),"^")
- ;
- S TRANDAT3=$G(^PRCS(410,PRCPDA,3)),VENDOR=+$P(TRANDAT3,"^",4)
- S DEPART=$P($G(^PRC(420,+TRANDATA,1,+$P(TRANDATA,"-",4),0)),"^",18)
- S:DEPART="" DEPART=$P($G(^PRCP(445,PRIMARY,0)),"^",8) I DEPART'="" S DEPART=DEPART_" "_$$INVNAME^PRCPUX1(PRIMARY)
- S:DEPART="" DEPART=$P($G(^DIC(49,+$P(TRANDAT3,"^",5),0)),"^")
- ;
- S TRANDAT7=$G(^PRCS(410,PRCPDA,7)),USER=$P($G(^VA(200,+TRANDAT7,0)),"^")
- S TRANDAT9=$G(^PRCS(410,PRCPDA,9))
- ;
- D NOW^%DTC S (NOWDT,Y)=% D DD^%DT S NOW=Y
- K ^TMP($J,"PRCPIB")
- S LINEDA=0 F S LINEDA=$O(^PRCS(410,PRCPDA,"IT",LINEDA)) Q:'LINEDA S D=$G(^(LINEDA,0)) I D'="" D
- . S LINEITEM=+$P(D,"^"),ITEMDA=+$P(D,"^",5),ITEMDATA=$G(^PRCP(445,PRIMARY,1,ITEMDA,0))
- . S TEMPLVL="" I $P(ITEMDATA,"^",23),$P(ITEMDATA,"^",24)>NOWDT S TEMPLVL=$P(ITEMDATA,"^",23)
- . S STAR="",MULTIPLE=$P($G(^PRC(441,ITEMDA,2,VENDOR,0)),"^",11) I MULTIPLE S %=$P(D,"^",2)/MULTIPLE I $P(%,".",2) S STAR="*"
- . S DESCR=$G(^PRCS(410,PRCPDA,"IT",LINEDA,1,1,0)) I DESCR="" S DESCR=$$DESCR^PRCPUX1(PRIMARY,ITEMDA)
- . S NSN=$$NSN^PRCPUX1(ITEMDA)
- . S DESCNSN=$S(SORT="A":DESCR,1:NSN) S:DESCNSN="" DESCNSN=" "
- . S ^TMP($J,"PRCPRIB",DESCNSN,LINEITEM,LINEDA)=$$UNITCODE^PRCPUX1(+$P(D,"^",3))_"^"_+$P(ITEMDATA,"^",9)_"^"_+$P(ITEMDATA,"^",7)_"^"_TEMPLVL_"^"_MULTIPLE_"^"_STAR_"^"_DESCR_"^"_NSN
- D PRINT^PRCPRIB1
- K ^TMP($J,"PRCPRIB")
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRIB0 2582 printed Feb 18, 2025@23:41:17 Page 2
- PRCPRIB0 ;WISC/RFJ-issue book request form(called from ifcap only) ;22 Dec 92
- +1 ;;5.1;IFCAP;;Oct 20, 2000
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- DQ ; called from ifcap (not prcp*) to print issue book request
- +1 ; form
- +2 ; prcprib = internal entry to 410
- +3 NEW %,%H,%I,CLASS,D,DATA,DEPART,DESCNSN,DESCR,ITEMDA,ITEMDATA,LINEDA,LINEITEM,MULTIPLE,NOW,NOWDT,NSN,P,PAGE,PRCPDA,PRCPFLAG,PRIMARY,PRIMDATA,SCREEN,SORT,STAR,TEMPLVL,TOTAL,TRANDAT1,TRANDAT3,TRANDAT7,TRANDAT9,TRANDATA,USER,VENDOR,X,Y
- +4 SET PRCPDA=+$GET(PRCPRIB)
- SET TRANDATA=$GET(^PRCS(410,PRCPDA,0))
- IF TRANDATA=""
- WRITE !!,"ERROR -- NUMBER '",PRCPDA,"' NOT IN CONTROL POINT ACTIVITY FILE"
- QUIT
- +5 SET PRIMARY=+$PIECE(TRANDATA,"^",6)
- SET PRIMDATA=$GET(^PRCP(445,PRIMARY,0))
- +6 SET SORT=$PIECE($GET(^PRC(411,+TRANDATA,0)),"^",21)
- IF $TRANSLATE($PIECE(PRIMDATA,"^",10),"S")'=""
- SET SORT=$PIECE(PRIMDATA,"^",10)
- +7 if SORT=""
- SET SORT="N"
- +8 ;
- +9 SET TRANDAT1=$GET(^PRCS(410,PRCPDA,1))
- SET %=$PIECE(TRANDAT1,"^",3)
- SET $PIECE(TRANDAT1,"^",3)=$SELECT(%="ST":"STANDARD",%="EM":"EMERGENCY",%="SP":"SPECIAL",1:"<< NOT SPECIFIED >>")
- +10 SET Y=$PIECE(TRANDAT1,"^")
- DO DD^%DT
- SET $PIECE(TRANDAT1,"^")=Y
- SET Y=$PIECE(TRANDAT1,"^",4)
- DO DD^%DT
- SET $PIECE(TRANDAT1,"^",4)=Y
- +11 SET CLASS=$PIECE($GET(^PRCS(410.2,+$PIECE(TRANDAT1,"^",5),0)),"^")
- +12 ;
- +13 SET TRANDAT3=$GET(^PRCS(410,PRCPDA,3))
- SET VENDOR=+$PIECE(TRANDAT3,"^",4)
- +14 SET DEPART=$PIECE($GET(^PRC(420,+TRANDATA,1,+$PIECE(TRANDATA,"-",4),0)),"^",18)
- +15 if DEPART=""
- SET DEPART=$PIECE($GET(^PRCP(445,PRIMARY,0)),"^",8)
- IF DEPART'=""
- SET DEPART=DEPART_" "_$$INVNAME^PRCPUX1(PRIMARY)
- +16 if DEPART=""
- SET DEPART=$PIECE($GET(^DIC(49,+$PIECE(TRANDAT3,"^",5),0)),"^")
- +17 ;
- +18 SET TRANDAT7=$GET(^PRCS(410,PRCPDA,7))
- SET USER=$PIECE($GET(^VA(200,+TRANDAT7,0)),"^")
- +19 SET TRANDAT9=$GET(^PRCS(410,PRCPDA,9))
- +20 ;
- +21 DO NOW^%DTC
- SET (NOWDT,Y)=%
- DO DD^%DT
- SET NOW=Y
- +22 KILL ^TMP($JOB,"PRCPIB")
- +23 SET LINEDA=0
- FOR
- SET LINEDA=$ORDER(^PRCS(410,PRCPDA,"IT",LINEDA))
- if 'LINEDA
- QUIT
- SET D=$GET(^(LINEDA,0))
- IF D'=""
- Begin DoDot:1
- +24 SET LINEITEM=+$PIECE(D,"^")
- SET ITEMDA=+$PIECE(D,"^",5)
- SET ITEMDATA=$GET(^PRCP(445,PRIMARY,1,ITEMDA,0))
- +25 SET TEMPLVL=""
- IF $PIECE(ITEMDATA,"^",23)
- IF $PIECE(ITEMDATA,"^",24)>NOWDT
- SET TEMPLVL=$PIECE(ITEMDATA,"^",23)
- +26 SET STAR=""
- SET MULTIPLE=$PIECE($GET(^PRC(441,ITEMDA,2,VENDOR,0)),"^",11)
- IF MULTIPLE
- SET %=$PIECE(D,"^",2)/MULTIPLE
- IF $PIECE(%,".",2)
- SET STAR="*"
- +27 SET DESCR=$GET(^PRCS(410,PRCPDA,"IT",LINEDA,1,1,0))
- IF DESCR=""
- SET DESCR=$$DESCR^PRCPUX1(PRIMARY,ITEMDA)
- +28 SET NSN=$$NSN^PRCPUX1(ITEMDA)
- +29 SET DESCNSN=$SELECT(SORT="A":DESCR,1:NSN)
- if DESCNSN=""
- SET DESCNSN=" "
- +30 SET ^TMP($JOB,"PRCPRIB",DESCNSN,LINEITEM,LINEDA)=$$UNITCODE^PRCPUX1(+$PIECE(D,"^",3))_"^"_+$PIECE(ITEMDATA,"^",9)_"^"_+$PIECE(ITEMDATA,"^",7)_"^"_TEMPLVL_"^"_MULTIPLE_"^"_STAR_"^"_DESCR_"^"_NSN
- End DoDot:1
- +31 DO PRINT^PRCPRIB1
- +32 KILL ^TMP($JOB,"PRCPRIB")
- +33 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +34 QUIT