- 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 Mar 13, 2025@21:20:04 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
