source: WorldVistAEHR/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCN2237.m@ 738

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1PRCN2237 ;SSI/SEB,ALA-Create 2237 from completed request ;[ 01/30/97 1:45 PM ]
2 ;;1.0;Equipment/Turn-In Request;**3,11,12**;Sep 13, 1996
3EN ; Entry point to individual 2237
4 S DIC("S")="I $P(^(0),U,7)=39!($P(^(0),U,7)=18)!($P(^(0),U,7)=19)",DIC="^PRCN(413,"
5 S DIC(0)="AEQZ" D ^DIC K DIC("S") G EXIT:Y<0 S IN=+Y
6 S PRCNTMP=$P(^PRCN(413,IN,0),U),P2237N=$S($D(^PRCS(410,"H",PRCNTMP)):0,1:1)
7 I 'P2237N D
8 . S DA=$O(^PRCS(410,"H",PRCNTMP,""))
9 . W !!,"2237 on File - Editing Transaction #: ",$P(^PRCS(410,DA,0),U),! K DA
10LIST ; Create 2237s for chosen requests
11 D EN^PRCSUT G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
12 I P2237N D
13 . D NEW S TDA=IN D LINE
14 . ; move justification
15 . S ^PRCS(410,DA(1),8,0)=^PRCN(413,TDA,36,0)
16 . S PRCNJ=0 F S PRCNJ=$O(^PRCN(413,TDA,36,PRCNJ)) Q:'PRCNJ S ^PRCS(410,DA(1),8,PRCNJ,0)=^PRCN(413,TDA,36,PRCNJ,0)
17 . K DR S (DIC,DIE)="^PRCS(410,",DA=DA(1)
18 . I $G(PRCNVNDR)'="",PRCNVNDR?.N S PRCNVNDR=$P(^PRC(440,PRCNVNDR,0),U)
19 . S DR="56///^S X=60;11//^S X=$G(PRCNVNDR);11.1;11.2;11.3;11.4;11.5;11.6;11.7;11.8;11.9;13" D ^DIE
20 . I $D(^PRCS(410,DA(1),"IT",1)) S ^PRCS(410,DA(1),10)=$O(^PRCS(410,DA(1),"IT",99),-1)_U_$P(^PRCS(410,DA(1),10),U,2,99)
21 I 'P2237N D
22 . S DA=$O(^PRCS(410,"H",PRCNTMP,"")),(DIC,DIE)="^PRCS(410,"
23 . S DR="[PRCN2237E]" D ^DIE
24 D CMP I $G(QFL)=1 W !!,$C(7),"2237 information is incomplete" G EXIT
25 D W61^PRCSEB I $G(%)=2 G EXIT
26 I $P($G(^PRCS(410,D0,7)),U,5)=""!($P($G(^(7)),U,7)="") G EXIT
27 I +$G(SPENDCP)=0 D
28 . S (DIE,DIC)="^PRCN(413,",DA=IN S:$G(PRCNT1)="" PRCNT1=$O(^PRCS(410,"H",PRCNTMP,""))
29 . S DR="6///^S X=34;7///^S X=DT;50////^S X=PRCNT1" D ^DIE
30 G EXIT
31NEW ; Create new 2237 and fill in info from a finished request
32 D EN1^PRCSUT3 G NQ:'X S X1=X D EN2^PRCSUT3 G NQ:'$D(X1) S X=X1,T1=DA
33 W !!,"This transaction is assigned transaction number: ",X
34 D LOCK^PRCSUT
35 S PRCNT1=T1,DIC="^PRCS(410,"
36 I $P(^PRCN(413,IN,0),U,14)'="" S SRTGRP=$P(^PRCN(413,IN,0),U,14)_";PRCS(410.7,"
37 S DIE=DIC,DR="[PRCN2237]" D ^DIE
38NQ K DIE,DA,DR,T1,X,X1 Q
39W2 W $C(7),!!,"You are not an authorized control point user."
40 W !,"Contact your control point official." S NGF=1
41EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSL,PRCSTT,I,N
42 K T,T1,T2,X,X1,PRCSX3,Y,PRCNTMP,QTY,COST,P2237N,PRCNT1,PRCNVNDR,TEST1
43 K IN,PRC,CURQTR,CURQTR1,PRCHQ,PRCSN,PRCST,PRCST1,SPENDCP,STRING,TEST
44 K %W,D0,DIW,DIWI,DIWT,DIWTC,DIWX,DN,OK,P1,PRCNJ,PRCSCP,PRCSERR,UTYP
45 K PRCSPG,PRCSQT,RECORD,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4
46 K SKIPRNT,STKNO,TDA,TRNODE,XNAME,JUMP,POP,PRCSCST,QFL,PDD1,SRTGRP
47 Q
48LINE ; Line item copier, called from [PRCN2237] input template
49 ;NEW DIEL,Y,DG,DI,DK,DL,DM,DP,DU,D0,D1,DA,DIC,DIE,DR,DOV
50CPLINE ; Create a line item in 2237 and copy over line item from request
51 N I S (I,C)=0 F S I=$O(^PRCN(413,TDA,1,"B",I)) Q:I'>0 S C=C+1
52 S DA=0 F S DA=$O(^PRCN(413,TDA,1,DA)) Q:'DA S LI=DA D L2 D Q:$D(DUOUT)
53 . W !!,"Line Item #",DA,":",!,"Description:"
54 . F II=1:1 Q:'$D(^PRCN(413,IN,1,LI,1,II)) S DL=^(II,0) D
55 .. W !," ",DL S ^PRCS(410,DA(1),"IT",LI,1,II,0)=DL
56 . W ! S ^PRCS(410,DA(1),"IT",LI,1,0)="^^"_(II-1)_U_(II-1)_U_DT
57 . I $P(^PRCN(413,IN,1,LI,0),U,12)="P",$P(^(0),U,2)'="" S PRCNVNDR=$P(^(0),U,2)
58 . I $G(PRCNVNDR)="" S PRCNVNDR=$P(^PRCN(413,IN,1,LI,0),U,13)
59 . D ^DIC Q:$G(DUOUT)=1!($G(DTOUT)=1) D ^DIE
60 K C,DLAYGO,DL,II,LI
61 Q
62L2 S DA(1)=PRCNT1,DIC(0)="LZ",DLAYGO=410,X=DA
63 S (DIE,DIC)="^PRCS(410,"_DA(1)_",""IT"","
64 I '$D(@(DIC_"0)")) S @(DIC_"0)")="^410.02AI^0^0"
65 D FILE^DICN
66 S QTY=$S($P(^PRCN(413,IN,1,LI,0),U,7)'="":$P(^(0),U,7),1:$P(^PRCN(413,IN,1,LI,0),U,5))
67 S COST=$P(^PRCN(413,IN,1,LI,0),U,4),STKNO=$P(^(0),U,3)
68 ; Special DRs to automatically copy line items from request
69 S UTYP=$O(^PRCD(420.5,"B","EA","")) S:UTYP="" UTYP="EA"
70 S (DR(1,410.02),DR)="2////^S X=QTY;3////^S X=UTYP;7////^S X=COST;4;6//^S X=STKNO;K PRCSV;10;S PRCSDR=""[2237]"""
71 S DR(1,410.02,1)="S PRCSVAR=$S($D(^PRCS(410,DA(1),""IT"",0)):^(0),1:"""");K PRCSV D 2^PRCSCK;I $D(PRCSERR)&PRCSERR S Y=""@1"" K PRCSERR;D QRB^PRCSCK;12;K PRCSMDP;"
72 Q
73CMP ; Check for completeness of data
74 S PDD1=0 F S PDD1=$O(^PRCS(410,D0,"IT",PDD1)) Q:'PDD1 D CMPD Q:QFL
75 Q
76CMPD S QFL=0 F I=1,2,3,4,7 I $P(^PRCS(410,D0,"IT",PDD1,0),U,I)="" S QFL=1
77 Q
Note: See TracBrowser for help on using the repository browser.