PRCPRPHW ;WISC/RFJ-physical count form ; 3/22/99 11:17am
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCPUSEL Q:'$G(PRCP("I"))
N %,%H,%I,A,ACCOUNT,ACCT,ACCTALL,D,DIR,DIRUT,DTOUT,DUOUT,ITEMDA,MAIN,NOW,NSN,PAGE,PRCPEXIT,PRCPFLAG,PRCPOH,SCREEN,X,Y
S PRCPOH=0
S XP="Do you need to print the ON-HAND column"
S XH="Enter 'YES' only if you are NOT performing a physical count."
W ! S %=$$YN^PRCPUYN(2)
I %=0 Q
I %=1 S PRCPOH=1
W !!,"Selected account codes will be used to generate the physical count form."
K ACCOUNT D ALLACCT I $G(PRCPFLAG) Q
F D I $G(PRCPFLAG) Q
. I $O(ACCOUNT("YES",0))!($G(ACCTALL)) D
. . W !!," Currently selected account codes:",!," "
. . I $G(ACCTALL) W "<< ALL ACCOUNT CODES >>"
. . E S A=0 F S A=$O(ACCOUNT("YES",A)) Q:'A W:$X>70 !," " W A," "
. . W !," You can DE-select one of the above account codes by reselecting it."
. I $O(ACCOUNT("NO",0)) D
. . W !!," Currently DE-selected account codes:",!," "
. . S A=0 F S A=$O(ACCOUNT("NO",A)) Q:'A W:$X>70 !," " W A," "
. . W !," You can RE-select one of the above account codes by reselecting it."
. W !!,"Select the number of the account code created, '^' to exit."
. S DIR(0)="SO^1:Account Code 1;2:Account Code 2;3:Account Code 3;6:Account Code 6;8:Account Code 8;",DIR("A")="Select ACCOUNT Code" D ^DIR I $D(DTOUT)!($D(DUOUT)) S (PRCPFLAG,PRCPEXIT)=1 Q
. S Y=+Y
. I Y=0,'$O(ACCOUNT("YES",0)),'$G(ACCTALL) D ALLACCT S:$G(PRCPFLAG) PRCPEXIT=1 Q
. I Y=0 S PRCPFLAG=1 Q
. I $G(ACCTALL),'$D(ACCOUNT("NO",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
. I $D(ACCOUNT("YES",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
. I $D(ACCOUNT("NO",Y)) K ACCOUNT("NO",Y) S ACCOUNT("YES",Y)="" W !?10,"RE-selected !" Q
. S ACCOUNT("YES",Y)="" W !?10,"selected !"
I $G(PRCPEXIT) D Q Q
I $G(ACCTALL) K ACCOUNT("YES")
I '$G(ACCTALL),'$O(ACCOUNT("YES",0)) W !!,"NO ACCOUNT CODES SELECTED." D Q Q
I $G(ACCTALL) F A=1,2,3,6,8 I '$D(ACCOUNT("NO",A)) S ACCOUNT("YES",A)=""
S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
. S ZTDESC="Physical Count Form",ZTRTN="DQ^PRCPRPHW"
. S ZTSAVE("PRCP*")="",ZTSAVE("ACC*")="",ZTSAVE("ZTREQ")="@"
W !!,"<*> please wait <*>"
DQ ;queue comes here
K ^TMP($J,"PRCPRPH"),PRCPFLAG
S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,PRCP("I"),1,ITEMDA)) Q:'ITEMDA S NSN=$$NSN^PRCPUX1(ITEMDA),ACCT=$$ACCT1^PRCPUX1($E(NSN,1,4)) I $D(ACCOUNT("YES",ACCT)) D
. S:NSN="" NSN=" "
. S %=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),MAIN=+$P(%,"^",6),MAIN=$$STORELOC^PRCPESTO(MAIN) S:MAIN="?" MAIN=" ?"
. S ^TMP($J,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$$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,"PRCPRPH",MAIN)) Q:MAIN=""!($G(PRCPFLAG)) D
. W !!?5,"MAIN STORAGE LOCATION: ",MAIN
. S ACCT="" F S ACCT=$O(^TMP($J,"PRCPRPH",MAIN,ACCT)) Q:ACCT=""!($G(PRCPFLAG)) D
. . W !?10,"ACCOUNT CODE: ",ACCT
. . S NSN="" F S NSN=$O(^TMP($J,"PRCPRPH",MAIN,ACCT,NSN)) Q:NSN=""!($G(PRCPFLAG)) S ITEMDA=0 F S ITEMDA=$O(^TMP($J,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)) Q:'ITEMDA!($G(PRCPFLAG)) S D=^(ITEMDA) D
. . . W !,$TR(NSN,"-"),?17,$E($P(D,"^"),1,23),?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") D ^%ZISC Q
;
;
ALLACCT ; select all account codes
K ACCTALL,PRCPFLAG
S XP="Do you want to select ALL account codes",XH="Enter 'YES' to generate the physical count form for ALL acount codes",XH(1)="enter 'NO' to print the physical count form for selectable account codes"
S XH(2)="or enter '^' to exit."
W ! S %=$$YN^PRCPUYN(1)
I %=2 Q
I %=1 S ACCTALL=1 Q
S PRCPFLAG=1 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 !,"NSN",?15,"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[HPRCPRPHW 4998 printed Nov 22, 2024@17:25:24 Page 2
PRCPRPHW ;WISC/RFJ-physical count form ; 3/22/99 11:17am
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 DO ^PRCPUSEL
if '$GET(PRCP("I"))
QUIT
+4 NEW %,%H,%I,A,ACCOUNT,ACCT,ACCTALL,D,DIR,DIRUT,DTOUT,DUOUT,ITEMDA,MAIN,NOW,NSN,PAGE,PRCPEXIT,PRCPFLAG,PRCPOH,SCREEN,X,Y
+5 SET PRCPOH=0
+6 SET XP="Do you need to print the ON-HAND column"
+7 SET XH="Enter 'YES' only if you are NOT performing a physical count."
+8 WRITE !
SET %=$$YN^PRCPUYN(2)
+9 IF %=0
QUIT
+10 IF %=1
SET PRCPOH=1
+11 WRITE !!,"Selected account codes will be used to generate the physical count form."
+12 KILL ACCOUNT
DO ALLACCT
IF $GET(PRCPFLAG)
QUIT
+13 FOR
Begin DoDot:1
+14 IF $ORDER(ACCOUNT("YES",0))!($GET(ACCTALL))
Begin DoDot:2
+15 WRITE !!," Currently selected account codes:",!," "
+16 IF $GET(ACCTALL)
WRITE "<< ALL ACCOUNT CODES >>"
+17 IF '$TEST
SET A=0
FOR
SET A=$ORDER(ACCOUNT("YES",A))
if 'A
QUIT
if $X>70
WRITE !," "
WRITE A," "
+18 WRITE !," You can DE-select one of the above account codes by reselecting it."
End DoDot:2
+19 IF $ORDER(ACCOUNT("NO",0))
Begin DoDot:2
+20 WRITE !!," Currently DE-selected account codes:",!," "
+21 SET A=0
FOR
SET A=$ORDER(ACCOUNT("NO",A))
if 'A
QUIT
if $X>70
WRITE !," "
WRITE A," "
+22 WRITE !," You can RE-select one of the above account codes by reselecting it."
End DoDot:2
+23 WRITE !!,"Select the number of the account code created, '^' to exit."
+24 SET DIR(0)="SO^1:Account Code 1;2:Account Code 2;3:Account Code 3;6:Account Code 6;8:Account Code 8;"
SET DIR("A")="Select ACCOUNT Code"
DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET (PRCPFLAG,PRCPEXIT)=1
QUIT
+25 SET Y=+Y
+26 IF Y=0
IF '$ORDER(ACCOUNT("YES",0))
IF '$GET(ACCTALL)
DO ALLACCT
if $GET(PRCPFLAG)
SET PRCPEXIT=1
QUIT
+27 IF Y=0
SET PRCPFLAG=1
QUIT
+28 IF $GET(ACCTALL)
IF '$DATA(ACCOUNT("NO",Y))
KILL ACCOUNT("YES",Y)
SET ACCOUNT("NO",Y)=""
WRITE !?10,"DE-selected !"
QUIT
+29 IF $DATA(ACCOUNT("YES",Y))
KILL ACCOUNT("YES",Y)
SET ACCOUNT("NO",Y)=""
WRITE !?10,"DE-selected !"
QUIT
+30 IF $DATA(ACCOUNT("NO",Y))
KILL ACCOUNT("NO",Y)
SET ACCOUNT("YES",Y)=""
WRITE !?10,"RE-selected !"
QUIT
+31 SET ACCOUNT("YES",Y)=""
WRITE !?10,"selected !"
End DoDot:1
IF $GET(PRCPFLAG)
QUIT
+32 IF $GET(PRCPEXIT)
DO Q
QUIT
+33 IF $GET(ACCTALL)
KILL ACCOUNT("YES")
+34 IF '$GET(ACCTALL)
IF '$ORDER(ACCOUNT("YES",0))
WRITE !!,"NO ACCOUNT CODES SELECTED."
DO Q
QUIT
+35 IF $GET(ACCTALL)
FOR A=1,2,3,6,8
IF '$DATA(ACCOUNT("NO",A))
SET ACCOUNT("YES",A)=""
+36 SET %ZIS="Q"
WRITE !
DO ^%ZIS
if POP
QUIT
IF $DATA(IO("Q"))
Begin DoDot:1
+37 SET ZTDESC="Physical Count Form"
SET ZTRTN="DQ^PRCPRPHW"
+38 SET ZTSAVE("PRCP*")=""
SET ZTSAVE("ACC*")=""
SET ZTSAVE("ZTREQ")="@"
End DoDot:1
DO ^%ZTLOAD
KILL IO("Q"),ZTSK
QUIT
+39 WRITE !!,"<*> please wait <*>"
DQ ;queue comes here
+1 KILL ^TMP($JOB,"PRCPRPH"),PRCPFLAG
+2 SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,PRCP("I"),1,ITEMDA))
if 'ITEMDA
QUIT
SET NSN=$$NSN^PRCPUX1(ITEMDA)
SET ACCT=$$ACCT1^PRCPUX1($EXTRACT(NSN,1,4))
IF $DATA(ACCOUNT("YES",ACCT))
Begin DoDot:1
+3 if NSN=""
SET NSN=" "
+4 SET %=$GET(^PRCP(445,PRCP("I"),1,ITEMDA,0))
SET MAIN=+$PIECE(%,"^",6)
SET MAIN=$$STORELOC^PRCPESTO(MAIN)
if MAIN="?"
SET MAIN=" ?"
+5 SET ^TMP($JOB,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$PIECE(%,"^",7)
End DoDot:1
+6 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET NOW=Y
SET PAGE=1
SET SCREEN=$$SCRPAUSE^PRCPUREP
USE IO
DO H
+7 SET MAIN=""
FOR
SET MAIN=$ORDER(^TMP($JOB,"PRCPRPH",MAIN))
if MAIN=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:1
+8 WRITE !!?5,"MAIN STORAGE LOCATION: ",MAIN
+9 SET ACCT=""
FOR
SET ACCT=$ORDER(^TMP($JOB,"PRCPRPH",MAIN,ACCT))
if ACCT=""!($GET(PRCPFLAG))
QUIT
Begin DoDot:2
+10 WRITE !?10,"ACCOUNT CODE: ",ACCT
+11 SET NSN=""
FOR
SET NSN=$ORDER(^TMP($JOB,"PRCPRPH",MAIN,ACCT,NSN))
if NSN=""!($GET(PRCPFLAG))
QUIT
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^TMP($JOB,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA))
if 'ITEMDA!($GET(PRCPFLAG))
QUIT
SET D=^(ITEMDA)
Begin DoDot:3
+12 WRITE !,$TRANSLATE(NSN,"-"),?17,$EXTRACT($PIECE(D,"^"),1,23),?42,ITEMDA,?47,$JUSTIFY($PIECE(D,"^",2),10)
+13 IF PRCPOH=1
WRITE $JUSTIFY($PIECE(D,"^",3),12)
+14 WRITE ?71,"_________"
+15 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
+16 IF Y=1
WRITE !?20,"ADD STORAGE: "
+17 IF $X>50
WRITE !?20
+18 WRITE $EXTRACT($$STORELOC^PRCPESTO($PIECE(D,"^")),1,15)," "
+19 IF $Y>(IOSL-4)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:4
+20 IF $GET(PRCPFLAG)
QUIT
+21 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:3
+22 IF $GET(PRCPFLAG)
QUIT
+23 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
+24 IF $GET(ZTQUEUED)
IF $$S^%ZTLOAD
SET PRCPFLAG=1
WRITE !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
End DoDot:2
+25 IF $GET(PRCPFLAG)
QUIT
+26 IF $Y>(IOSL-6)
if SCREEN
DO P^PRCPUREP
if $DATA(PRCPFLAG)
QUIT
DO H
End DoDot:1
+27 IF '$GET(PRCPFLAG)
DO END^PRCPUREP
Q KILL ^TMP($JOB,"PRCPRPH")
DO ^%ZISC
QUIT
+1 ;
+2 ;
ALLACCT ; select all account codes
+1 KILL ACCTALL,PRCPFLAG
+2 SET XP="Do you want to select ALL account codes"
SET XH="Enter 'YES' to generate the physical count form for ALL acount codes"
SET XH(1)="enter 'NO' to print the physical count form for selectable account codes"
+3 SET XH(2)="or enter '^' to exit."
+4 WRITE !
SET %=$$YN^PRCPUYN(1)
+5 IF %=2
QUIT
+6 IF %=1
SET ACCTALL=1
QUIT
+7 SET PRCPFLAG=1
QUIT
+8 ;
+9 ;
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 !,"NSN",?15,"DESCRIPTION",?42,"MI",?50,"UNIT/ISS"
+3 IF PRCPOH=1
WRITE ?62,"ON HAND"
+4 WRITE ?71,"NEW COUNT",!,%
+5 QUIT
