source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCPRPHW.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.8 KB
Line 
1PRCPRPHW ;WISC/RFJ-physical count form ; 3/22/99 11:17am
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 D ^PRCPUSEL Q:'$G(PRCP("I"))
5 N %,%H,%I,A,ACCOUNT,ACCT,ACCTALL,D,DIR,DIRUT,DTOUT,DUOUT,ITEMDA,MAIN,NOW,NSN,PAGE,PRCPEXIT,PRCPFLAG,PRCPOH,SCREEN,X,Y
6 S PRCPOH=0
7 S XP="Do you need to print the ON-HAND column"
8 S XH="Enter 'YES' only if you are NOT performing a physical count."
9 W ! S %=$$YN^PRCPUYN(2)
10 I %=0 Q
11 I %=1 S PRCPOH=1
12 W !!,"Selected account codes will be used to generate the physical count form."
13 K ACCOUNT D ALLACCT I $G(PRCPFLAG) Q
14 F D I $G(PRCPFLAG) Q
15 . I $O(ACCOUNT("YES",0))!($G(ACCTALL)) D
16 . . W !!," Currently selected account codes:",!," "
17 . . I $G(ACCTALL) W "<< ALL ACCOUNT CODES >>"
18 . . E S A=0 F S A=$O(ACCOUNT("YES",A)) Q:'A W:$X>70 !," " W A," "
19 . . W !," You can DE-select one of the above account codes by reselecting it."
20 . I $O(ACCOUNT("NO",0)) D
21 . . W !!," Currently DE-selected account codes:",!," "
22 . . S A=0 F S A=$O(ACCOUNT("NO",A)) Q:'A W:$X>70 !," " W A," "
23 . . W !," You can RE-select one of the above account codes by reselecting it."
24 . W !!,"Select the number of the account code created, '^' to exit."
25 . 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
26 . S Y=+Y
27 . I Y=0,'$O(ACCOUNT("YES",0)),'$G(ACCTALL) D ALLACCT S:$G(PRCPFLAG) PRCPEXIT=1 Q
28 . I Y=0 S PRCPFLAG=1 Q
29 . I $G(ACCTALL),'$D(ACCOUNT("NO",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
30 . I $D(ACCOUNT("YES",Y)) K ACCOUNT("YES",Y) S ACCOUNT("NO",Y)="" W !?10,"DE-selected !" Q
31 . I $D(ACCOUNT("NO",Y)) K ACCOUNT("NO",Y) S ACCOUNT("YES",Y)="" W !?10,"RE-selected !" Q
32 . S ACCOUNT("YES",Y)="" W !?10,"selected !"
33 I $G(PRCPEXIT) D Q Q
34 I $G(ACCTALL) K ACCOUNT("YES")
35 I '$G(ACCTALL),'$O(ACCOUNT("YES",0)) W !!,"NO ACCOUNT CODES SELECTED." D Q Q
36 I $G(ACCTALL) F A=1,2,3,6,8 I '$D(ACCOUNT("NO",A)) S ACCOUNT("YES",A)=""
37 S %ZIS="Q" W ! D ^%ZIS Q:POP I $D(IO("Q")) D D ^%ZTLOAD K IO("Q"),ZTSK Q
38 . S ZTDESC="Physical Count Form",ZTRTN="DQ^PRCPRPHW"
39 . S ZTSAVE("PRCP*")="",ZTSAVE("ACC*")="",ZTSAVE("ZTREQ")="@"
40 W !!,"<*> please wait <*>"
41DQ ;queue comes here
42 K ^TMP($J,"PRCPRPH"),PRCPFLAG
43 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
44 . S:NSN="" NSN=" "
45 . S %=$G(^PRCP(445,PRCP("I"),1,ITEMDA,0)),MAIN=+$P(%,"^",6),MAIN=$$STORELOC^PRCPESTO(MAIN) S:MAIN="?" MAIN=" ?"
46 . S ^TMP($J,"PRCPRPH",MAIN,ACCT,NSN,ITEMDA)=$$DESCR^PRCPUX1(PRCP("I"),ITEMDA)_"^"_$$UNIT^PRCPUX1(PRCP("I"),ITEMDA,"/")_"^"_$P(%,"^",7)
47 D NOW^%DTC S Y=% D DD^%DT S NOW=Y,PAGE=1,SCREEN=$$SCRPAUSE^PRCPUREP U IO D H
48 S MAIN="" F S MAIN=$O(^TMP($J,"PRCPRPH",MAIN)) Q:MAIN=""!($G(PRCPFLAG)) D
49 . W !!?5,"MAIN STORAGE LOCATION: ",MAIN
50 . S ACCT="" F S ACCT=$O(^TMP($J,"PRCPRPH",MAIN,ACCT)) Q:ACCT=""!($G(PRCPFLAG)) D
51 . . W !?10,"ACCOUNT CODE: ",ACCT
52 . . 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
53 . . . W !,$TR(NSN,"-"),?17,$E($P(D,"^"),1,23),?42,ITEMDA,?47,$J($P(D,"^",2),10)
54 . . . I PRCPOH=1 W $J($P(D,"^",3),12)
55 . . . W ?71,"_________"
56 . . . 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
57 . . . . I Y=1 W !?20,"ADD STORAGE: "
58 . . . . I $X>50 W !?20
59 . . . . W $E($$STORELOC^PRCPESTO($P(D,"^")),1,15)," "
60 . . . . I $Y>(IOSL-4) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
61 . . . I $G(PRCPFLAG) Q
62 . . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
63 . . I $G(PRCPFLAG) Q
64 . . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
65 . . I $G(ZTQUEUED),$$S^%ZTLOAD S PRCPFLAG=1 W !?10,"<<< TASKMANAGER JOB TERMINATED BY USER >>>"
66 . I $G(PRCPFLAG) Q
67 . I $Y>(IOSL-6) D:SCREEN P^PRCPUREP Q:$D(PRCPFLAG) D H
68 I '$G(PRCPFLAG) D END^PRCPUREP
69Q K ^TMP($J,"PRCPRPH") D ^%ZISC Q
70 ;
71 ;
72ALLACCT ; select all account codes
73 K ACCTALL,PRCPFLAG
74 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"
75 S XH(2)="or enter '^' to exit."
76 W ! S %=$$YN^PRCPUYN(1)
77 I %=2 Q
78 I %=1 S ACCTALL=1 Q
79 S PRCPFLAG=1 Q
80 ;
81 ;
82H S %=NOW_" PAGE "_PAGE,PAGE=PAGE+1 I PAGE'=2!(SCREEN) W @IOF
83 W $C(13),"PHYSICAL COUNT FORM: ",$E(PRCP("IN"),1,12),?(80-$L(%)),%
84 S %="",$P(%,"-",81)="" W !,"NSN",?15,"DESCRIPTION",?42,"MI",?50,"UNIT/ISS"
85 I PRCPOH=1 W ?62,"ON HAND"
86 W ?71,"NEW COUNT",!,%
87 Q
Note: See TracBrowser for help on using the repository browser.