- PRCPRDO1 ;WISC/RFJ-distribution duein and dueout reports ; 7/9/99 3:39pm
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- DQ ; queue comes here
- N %,%I,D,DATA,INVPT,ITEMDA,ITEMDATA,NOW,ORDDATA,ORDERDA,PAGE,PRCPFLAG,PRIMARDA,QTY,SCREEN,SECONDA,TOTAL,VDA,VDATA,XREF,X,Y
- K ^TMP($J,"PRCPRDOR")
- S XREF="AC" I PRCP("DPTYPE")="S" S XREF="AD"
- S ORDERDA=0 F S ORDERDA=$O(^PRCP(445.3,XREF,PRCP("I"),ORDERDA)) Q:'ORDERDA D
- . I $G(UPDATE) L +^PRCP(445.3,ORDERDA)
- . S ORDDATA=$G(^PRCP(445.3,ORDERDA,0))
- . I $P(ORDDATA,"^",6)=""!($P(ORDDATA,"^",6)="P") L -^PRCP(445.3,ORDERDA) Q
- . S PRIMARDA=+$P(ORDDATA,"^",2),SECONDA=+$P(ORDDATA,"^",3)
- . S ITEMDA=0 F S ITEMDA=$O(^PRCP(445.3,ORDERDA,1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^PRCP(445.3,ORDERDA,1,ITEMDA,0)) I ITEMDATA'="" D
- . . S QTY=$P(ITEMDATA,"^",2)
- . . S VDATA=$$GETVEN^PRCPUVEN(SECONDA,ITEMDA,PRIMARDA_";PRCP(445,",1)
- . . S ^TMP($J,"PRCPRDOR",ITEMDA,ORDERDA)=PRIMARDA_"^"_SECONDA_"^"_(QTY*$P(VDATA,"^",4))_"^"_QTY_"^"_$$UNIT^PRCPUX1(PRIMARDA,ITEMDA,"/")_"^"_$$UNIT^PRCPUX1(SECONDA,ITEMDA,"/")_"^"_$P(VDATA,"^",4)
- . I $G(UPDATE) L -^PRCP(445.3,ORDERDA)
- ;
- ; print report from tmp global
- K ^TMP($J,"PRCPUPDATE")
- D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
- S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRDOR",ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) D
- . S ITEMDATA=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- . S QTY=$S(TYPE="IN":$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),1:$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA))
- . W !!,$E($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?27,"#",ITEMDA,?35,$J($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$J(+$P(ITEMDATA,"^",7),15),$J(QTY,21)
- . S (ORDERDA,TOTAL)=0 F S ORDERDA=$O(^TMP($J,"PRCPRDOR",ITEMDA,ORDERDA)) Q:'ORDERDA!($G(PRCPFLAG)) S DATA=^(ORDERDA) D
- . . S D=$G(^PRCP(445.3,ORDERDA,0)),Y=$P($P(D,"^",4),".") S:'Y Y="?" D DD^%DT
- . . W !?5,$P(D,"^"),?12,Y,?24,$S($P(D,"^",8)="R":"REGU",$P(D,"^",8)="C":"CALL",$P(D,"^",8)="E":"EMER",1:"----"),?29,$S($P(D,"^",6)="R":"RELE",$P(D,"^",6)="B":"BACK",1:"----")
- . . S INVPT=$P(DATA,"^") I TYPE="OUT" S INVPT=$P(DATA,"^",2)
- . . W ?36,$E($P($$INVNAME^PRCPUX1(INVPT),"-",2),1,16)
- . . I TYPE="OUT" W ?69,$J(+$P(DATA,"^",4),11) S TOTAL=TOTAL+$P(DATA,"^",4)
- . . I TYPE="IN" W ?53,$J($P(DATA,"^",6),9),$J($P(DATA,"^",7),7),$J(+$P(DATA,"^",3),11) S TOTAL=TOTAL+$P(DATA,"^",3)
- . . I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
- . I $G(PRCPFLAG) Q
- . I +TOTAL'=+QTY W !?5,"** CURRENT QUANTITY DUE-",TYPE,$S($G(UPDATE):" IS NOW EQUAL TO",1:" DOES NOT MATCH")," CALCULATED QUANTITY DUE-",TYPE," **"
- . I $G(UPDATE) S ^TMP($J,"PRCPUPDATE",ITEMDA)=TOTAL
- . I $Y>(IOSL-5) D:SCREEN P^PRCPUREP Q:$G(PRCPFLAG) D H
- ;
- ; update dueins or dueouts
- I $G(UPDATE) S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA I $D(^(ITEMDA,0)) D
- . ; subtract off current qty duein,out to reset to zero
- . S QTY=$G(^TMP($J,"PRCPUPDATE",ITEMDA))-$S(TYPE="IN":$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),1:$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA))
- . I TYPE="IN" D SETIN^PRCPUDUE(PRCP("I"),ITEMDA,QTY) Q
- . D SETOUT^PRCPUDUE(PRCP("I"),ITEMDA,QTY)
- ;
- I '$G(PRCPFLAG) D END^PRCPUREP
- D ^%ZISC
- K ^TMP($J,"PRCPRDOR"),^TMP($J,"PRCPUDPATE")
- Q
- ;
- ;
- H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
- W $C(13),"DUE-",TYPE," ITEM REPORT FOR ",PRCP("IN"),?(80-$L(%)),%
- W !,"ITEM DESCRIPTION",?27,"#MI",?35,$J("UNIT/IS",9),$J("QTY ON-HAND",15),$J("QTY DUE-"_TYPE,21)
- W !?5,"ORD#",?12,"DATE ORD",?24,"TYPE",?29,"STAT",?36,$S(TYPE="IN":"FROM",1:"TO")," INVPT"
- I TYPE="OUT" W ?69,"QTY DUE-OUT"
- I TYPE="IN" W ?55,"UNIT/REC",?67,"CF",?70,"QTY DUE-IN"
- S %="",$P(%,"-",81)="" W !,%
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRDO1 3805 printed Mar 13, 2025@21:19:37 Page 2
- PRCPRDO1 ;WISC/RFJ-distribution duein and dueout reports ; 7/9/99 3:39pm
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 QUIT
- +3 ;
- +4 ;
- DQ ; queue comes here
- +1 NEW %,%I,D,DATA,INVPT,ITEMDA,ITEMDATA,NOW,ORDDATA,ORDERDA,PAGE,PRCPFLAG,PRIMARDA,QTY,SCREEN,SECONDA,TOTAL,VDA,VDATA,XREF,X,Y
- +2 KILL ^TMP($JOB,"PRCPRDOR")
- +3 SET XREF="AC"
- IF PRCP("DPTYPE")="S"
- SET XREF="AD"
- +4 SET ORDERDA=0
- FOR
- SET ORDERDA=$ORDER(^PRCP(445.3,XREF,PRCP("I"),ORDERDA))
- if 'ORDERDA
- QUIT
- Begin DoDot:1
- +5 IF $GET(UPDATE)
- LOCK +^PRCP(445.3,ORDERDA)
- +6 SET ORDDATA=$GET(^PRCP(445.3,ORDERDA,0))
- +7 IF $PIECE(ORDDATA,"^",6)=""!($PIECE(ORDDATA,"^",6)="P")
- LOCK -^PRCP(445.3,ORDERDA)
- QUIT
- +8 SET PRIMARDA=+$PIECE(ORDDATA,"^",2)
- SET SECONDA=+$PIECE(ORDDATA,"^",3)
- +9 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445.3,ORDERDA,1,ITEMDA))
- if 'ITEMDA
- QUIT
- SET ITEMDATA=$GET(^PRCP(445.3,ORDERDA,1,ITEMDA,0))
- IF ITEMDATA'=""
- Begin DoDot:2
- +10 SET QTY=$PIECE(ITEMDATA,"^",2)
- +11 SET VDATA=$$GETVEN^PRCPUVEN(SECONDA,ITEMDA,PRIMARDA_";PRCP(445,",1)
- +12 SET ^TMP($JOB,"PRCPRDOR",ITEMDA,ORDERDA)=PRIMARDA_"^"_SECONDA_"^"_(QTY*$PIECE(VDATA,"^",4))_"^"_QTY_"^"_$$UNIT^PRCPUX1(PRIMARDA,ITEMDA,"/")_"^"_$$UNIT^PRCPUX1(SECONDA,ITEMDA,"/")_"^"_$PIECE(VDATA,"^",4)
- End DoDot:2
- +13 IF $GET(UPDATE)
- LOCK -^PRCP(445.3,ORDERDA)
- End DoDot:1
- +14 ;
- +15 ; print report from tmp global
- +16 KILL ^TMP($JOB,"PRCPUPDATE")
- +17 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET NOW=Y
- SET PAGE=1
- SET SCREEN=$$SCRPAUSE^PRCPUREP
- USE IO
- DO H
- +18 SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRDOR",ITEMDA))
- if 'ITEMDA!($GET(PRCPFLAG))
- QUIT
- Begin DoDot:1
- +19 SET ITEMDATA=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
- +20 SET QTY=$SELECT(TYPE="IN":$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),1:$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA))
- +21 WRITE !!,$EXTRACT($$DESCR^PRCPUX1(PRCP("I"),ITEMDA),1,25),?27,"#",ITEMDA,?35,$JUSTIFY($$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/"),9),$JUSTIFY(+$PIECE(ITEMDATA,"^",7),15),$JUSTIFY(QTY,21)
- +22 SET (ORDERDA,TOTAL)=0
- FOR
- SET ORDERDA=$ORDER(^TMP($JOB,"PRCPRDOR",ITEMDA,ORDERDA))
- if 'ORDERDA!($GET(PRCPFLAG))
- QUIT
- SET DATA=^(ORDERDA)
- Begin DoDot:2
- +23 SET D=$GET(^PRCP(445.3,ORDERDA,0))
- SET Y=$PIECE($PIECE(D,"^",4),".")
- if 'Y
- SET Y="?"
- DO DD^%DT
- +24 WRITE !?5,$PIECE(D,"^"),?12,Y,?24,$SELECT($PIECE(D,"^",8)="R":"REGU",$PIECE(D,"^",8)="C":"CALL",$PIECE(D,"^",8)="E":"EMER",1:"----"),?29,$SELECT($PIECE(D,"^",6)="R":"RELE",$PIECE(D,"^",6)="B":"BACK",1:"----")
- +25 SET INVPT=$PIECE(DATA,"^")
- IF TYPE="OUT"
- SET INVPT=$PIECE(DATA,"^",2)
- +26 WRITE ?36,$EXTRACT($PIECE($$INVNAME^PRCPUX1(INVPT),"-",2),1,16)
- +27 IF TYPE="OUT"
- WRITE ?69,$JUSTIFY(+$PIECE(DATA,"^",4),11)
- SET TOTAL=TOTAL+$PIECE(DATA,"^",4)
- +28 IF TYPE="IN"
- WRITE ?53,$JUSTIFY($PIECE(DATA,"^",6),9),$JUSTIFY($PIECE(DATA,"^",7),7),$JUSTIFY(+$PIECE(DATA,"^",3),11)
- SET TOTAL=TOTAL+$PIECE(DATA,"^",3)
- +29 IF $Y>(IOSL-5)
- if SCREEN
- DO P^PRCPUREP
- if $GET(PRCPFLAG)
- QUIT
- DO H
- End DoDot:2
- +30 IF $GET(PRCPFLAG)
- QUIT
- +31 IF +TOTAL'=+QTY
- WRITE !?5,"** CURRENT QUANTITY DUE-",TYPE,$SELECT($GET(UPDATE):" IS NOW EQUAL TO",1:" DOES NOT MATCH")," CALCULATED QUANTITY DUE-",TYPE," **"
- +32 IF $GET(UPDATE)
- SET ^TMP($JOB,"PRCPUPDATE",ITEMDA)=TOTAL
- +33 IF $Y>(IOSL-5)
- if SCREEN
- DO P^PRCPUREP
- if $GET(PRCPFLAG)
- QUIT
- DO H
- End DoDot:1
- +34 ;
- +35 ; update dueins or dueouts
- +36 IF $GET(UPDATE)
- SET ITEMDA=0
- FOR
- SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
- if 'ITEMDA
- QUIT
- IF $DATA(^(ITEMDA,0))
- Begin DoDot:1
- +37 ; subtract off current qty duein,out to reset to zero
- +38 SET QTY=$GET(^TMP($JOB,"PRCPUPDATE",ITEMDA))-$SELECT(TYPE="IN":$$GETIN^PRCPUDUE(PRCP("I"),ITEMDA),1:$$GETOUT^PRCPUDUE(PRCP("I"),ITEMDA))
- +39 IF TYPE="IN"
- DO SETIN^PRCPUDUE(PRCP("I"),ITEMDA,QTY)
- QUIT
- +40 DO SETOUT^PRCPUDUE(PRCP("I"),ITEMDA,QTY)
- End DoDot:1
- +41 ;
- +42 IF '$GET(PRCPFLAG)
- DO END^PRCPUREP
- +43 DO ^%ZISC
- +44 KILL ^TMP($JOB,"PRCPRDOR"),^TMP($JOB,"PRCPUDPATE")
- +45 QUIT
- +46 ;
- +47 ;
- H SET %=NOW_" PAGE "_PAGE
- SET PAGE=PAGE+1
- IF PAGE'=2!(SCREEN)
- WRITE @IOF
- +1 WRITE $CHAR(13),"DUE-",TYPE," ITEM REPORT FOR ",PRCP("IN"),?(80-$LENGTH(%)),%
- +2 WRITE !,"ITEM DESCRIPTION",?27,"#MI",?35,$JUSTIFY("UNIT/IS",9),$JUSTIFY("QTY ON-HAND",15),$JUSTIFY("QTY DUE-"_TYPE,21)
- +3 WRITE !?5,"ORD#",?12,"DATE ORD",?24,"TYPE",?29,"STAT",?36,$SELECT(TYPE="IN":"FROM",1:"TO")," INVPT"
- +4 IF TYPE="OUT"
- WRITE ?69,"QTY DUE-OUT"
- +5 IF TYPE="IN"
- WRITE ?55,"UNIT/REC",?67,"CF",?70,"QTY DUE-IN"
- +6 SET %=""
- SET $PIECE(%,"-",81)=""
- WRITE !,%
- +7 QUIT
