PRCPRPH1 ;WISC/RFJ-physical count form for prim and sec (cont);02 Feb 93 ; 3/22/99 11:30am
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
DQ ;come here to print report
K PRCPFLAG,^TMP($J,"PRCPRPHP")
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S GROUP=+$P($G(^(ITEMDA,0)),"^",21) D
. I $D(^TMP($J,"PRCPRPH","NO",GROUP)) Q
. I GROUP,'$D(GROUPALL),'$D(^TMP($J,"PRCPRPH","YES",GROUP)) Q
. I 'GROUP,'$D(GROUPALL) Q
. S %=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),MAIN=+$P(%,"^",6),MAIN=$$STORELOC^PRCPESTO(MAIN) S:MAIN="?" MAIN=" ?"
. S DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA) S:DESCR="" DESCR=" "
. S ^TMP($J,"PRCPRPHP",MAIN,GROUP,$E(DESCR,1,15),ITEMDA)=DESCR_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$P(%,"^",7)
D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
S MAIN="" F S MAIN=$O(^TMP($J,"PRCPRPHP",MAIN)) Q:MAIN=""!($G(PRCPFLAG)) D
. W !!?5,"MAIN STORAGE LOCATION: ",MAIN
. S GROUP="" F S GROUP=$O(^TMP($J,"PRCPRPHP",MAIN,GROUP)) Q:GROUP=""!($G(PRCPFLAG)) D
. . W !?10,"GROUP CATEGORY: ",$$GROUPNM^PRCPEGRP(GROUP)
. . S DESCR="" F S DESCR=$O(^TMP($J,"PRCPRPHP",MAIN,GROUP,DESCR)) Q:DESCR=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRPHP",MAIN,GROUP,DESCR,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S D=^(ITEMDA) D
. . . W !,$E($P(D,"^",1),1,40),?42,ITEMDA,?47,$J($P(D,"^",2),10)
. . . I PRCPOH=1 W $J($P(D,"^",3),12)
. . . W ?71,"_________"
. . . S X=0 F Y=1:1 S X=$O(^PRCP(445,PRCP("I"),1,ITEMDA,1,X)) Q:'X S D=$G(^(X,0)) I D'="" D
. . . . I Y=1 W !?20,"ADD STORAGE: "
. . . . I $X>50 W !?20
. . . . W $E($$STORELOC^PRCPESTO($P(D,"^")),1,15)," "
. . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . . I $G(PRCPFLAG) Q
. . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . I $G(PRCPFLAG) Q
. . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
. . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
. I $G(PRCPFLAG) Q
. I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
I '$G(PRCPFLAG) D END^PRCPUREP
Q K ^TMP($J,"PRCPRPH"),^TMP($J,"PRCPRPHP") D ^%ZISC Q
;
;
H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
W $C(13),"PHYSICAL COUNT FORM: ",$E(PRCP("IN"),1,12),?(80-$L(%)),%
S %="",$P(%,"-",81)="" W !,"DESCRIPTION",?42,"MI",?50,"UNIT/ISS"
I PRCPOH=1 W ?62,"ON HAND"
W ?71,"NEW COUNT",!,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPRPH1 2591 printed Dec 13, 2024@02:15:17 Page 2
PRCPRPH1 ;WISC/RFJ-physical count form for prim and sec (cont);02 Feb 93 ; 3/22/99 11:30am
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 ;come here to print report
+1 KILL PRCPFLAG,^TMP($JOB,"PRCPRPHP")
+2 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET GROUP=+$PIECE($GET(^(ITEMDA,0)),"^",21)
Begin DoDot:1
+3 IF $DATA(^TMP($JOB,"PRCPRPH","NO",GROUP))
QUIT
+4 IF GROUP
IF '$DATA(GROUPALL)
IF '$DATA(^TMP($JOB,"PRCPRPH","YES",GROUP))
QUIT
+5 IF 'GROUP
IF '$DATA(GROUPALL)
QUIT
+6 SET %=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
SET MAIN=+$PIECE(%,"^",6)
SET MAIN=$$STORELOC^PRCPESTO(MAIN)
if MAIN="?"
SET MAIN=" ?"
+7 SET DESCR=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)
if DESCR=""
SET DESCR=" "
+8 SET ^TMP($JOB,"PRCPRPHP",MAIN,GROUP,$EXTRACT(DESCR,1,15),ITEMDA)=DESCR_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$PIECE(%,"^",7)
End DoDot:1
+9 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+10 SET MAIN=""
FOR
SET MAIN=$ORDER(^TMP($JOB,"PRCPRPHP",MAIN))
if MAIN=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+11 WRITE !!?5,"MAIN STORAGE LOCATION: ",MAIN
+12 SET GROUP=""
FOR
SET GROUP=$ORDER(^TMP($JOB,"PRCPRPHP",MAIN,GROUP))
if GROUP=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+13 WRITE !?10,"GROUP CATEGORY: ",$$GROUPNM^PRCPEGRP(GROUP)
+14 SET DESCR=""
FOR
SET DESCR=$ORDER(^TMP($JOB,"PRCPRPHP",MAIN,GROUP,DESCR))
if DESCR=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRPHP",MAIN,GROUP,DESCR,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET D=^(ITEMDA)
Begin DoDot:3
+15 WRITE !,$EXTRACT($PIECE(D,"^",1),1,40),?42,ITEMDA,?47,$JUSTIFY($PIECE(D,"^",2),10)
+16 IF PRCPOH=1
WRITE $JUSTIFY($PIECE(D,"^",3),12)
+17 WRITE ?71,"_________"
+18 SET X=0
FOR Y=1:1
SET X=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA,1,X))
if 'X
QUIT
SET D=$GET(^(X,0))
IF D'=""
Begin DoDot:4
+19 IF Y=1
WRITE !?20,"ADD STORAGE: "
+20 IF $X>50
WRITE !?20
+21 WRITE $EXTRACT($$STORELOC^PRCPESTO($PIECE(D,"^")),1,15)," "
+22 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:4
+23 IF $GET(PRCPFLAG)
QUIT
+24 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:3
+25 IF $GET(PRCPFLAG)
QUIT
+26 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+27 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
End DoDot:2
+28 IF $GET(PRCPFLAG)
QUIT
+29 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+30 IF '$GET(PRCPFLAG)
DO END^PRCPUREP
Q KILL ^TMP($JOB,"PRCPRPH"),^TMP($JOB,"PRCPRPHP")
DO ^%ZISC
QUIT
+1 ;
+2 ;
H SET %=NOW_" PAGE "_PAGE
SET PAGE=PAGE+1
IF PAGE'=2!(SCREEN)
WRITE @IOF
+1 WRITE $CHAR(13),"PHYSICAL COUNT FORM: ",$EXTRACT(PRCP("IN"),1,12),?(80-$LENGTH(%)),%
+2 SET %=""
SET $PIECE(%,"-",81)=""
WRITE !,"DESCRIPTION",?42,"MI",?50,"UNIT/ISS"
+3 IF PRCPOH=1
WRITE ?62,"ON HAND"
+4 WRITE ?71,"NEW COUNT",!,%
+5 QUIT
