source: FOIAVistA/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCN2237.m@ 1607

PRCN2237 ;SSI/SEB,ALA-Create 2237 from completed request ;[ 01/30/97  1:45 PM ]
 ;;1.0;Equipment/Turn-In Request;**3,11,12**;Sep 13, 1996
EN ;  Entry point to individual 2237
 S DIC("S")="I $P(^(0),U,7)=39!($P(^(0),U,7)=18)!($P(^(0),U,7)=19)",DIC="^PRCN(413,"
 S DIC(0)="AEQZ" D ^DIC K DIC("S") G EXIT:Y<0 S IN=+Y
 S PRCNTMP=$P(^PRCN(413,IN,0),U),P2237N=$S($D(^PRCS(410,"H",PRCNTMP)):0,1:1)
 I 'P2237N D
 . S DA=$O(^PRCS(410,"H",PRCNTMP,""))
 . W !!,"2237 on File - Editing Transaction #: ",$P(^PRCS(410,DA,0),U),! K DA
LIST ; Create 2237s for chosen requests
 D EN^PRCSUT G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0)
 I P2237N D
 . D NEW S TDA=IN D LINE
 . ;  move justification
 . S ^PRCS(410,DA(1),8,0)=^PRCN(413,TDA,36,0)
 . 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)
 . K DR S (DIC,DIE)="^PRCS(410,",DA=DA(1)
 . I $G(PRCNVNDR)'="",PRCNVNDR?.N S PRCNVNDR=$P(^PRC(440,PRCNVNDR,0),U)
 . 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
 . 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)
 I 'P2237N D
 . S DA=$O(^PRCS(410,"H",PRCNTMP,"")),(DIC,DIE)="^PRCS(410,"
 . S DR="[PRCN2237E]" D ^DIE
 D CMP I $G(QFL)=1 W !!,$C(7),"2237 information is incomplete" G EXIT
 D W61^PRCSEB I $G(%)=2 G EXIT
 I $P($G(^PRCS(410,D0,7)),U,5)=""!($P($G(^(7)),U,7)="") G EXIT
 I +$G(SPENDCP)=0 D
 . S (DIE,DIC)="^PRCN(413,",DA=IN S:$G(PRCNT1)="" PRCNT1=$O(^PRCS(410,"H",PRCNTMP,""))
 . S DR="6///^S X=34;7///^S X=DT;50////^S X=PRCNT1" D ^DIE
 G EXIT
NEW ; Create new 2237 and fill in info from a finished request
 D EN1^PRCSUT3 G NQ:'X S X1=X D EN2^PRCSUT3 G NQ:'$D(X1) S X=X1,T1=DA
 W !!,"This transaction is assigned transaction number: ",X
 D LOCK^PRCSUT
 S PRCNT1=T1,DIC="^PRCS(410,"
 I $P(^PRCN(413,IN,0),U,14)'="" S SRTGRP=$P(^PRCN(413,IN,0),U,14)_";PRCS(410.7,"
 S DIE=DIC,DR="[PRCN2237]" D ^DIE
NQ K DIE,DA,DR,T1,X,X1 Q
W2 W $C(7),!!,"You are not an authorized control point user."
 W !,"Contact your control point official." S NGF=1
EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSL,PRCSTT,I,N
 K T,T1,T2,X,X1,PRCSX3,Y,PRCNTMP,QTY,COST,P2237N,PRCNT1,PRCNVNDR,TEST1
 K IN,PRC,CURQTR,CURQTR1,PRCHQ,PRCSN,PRCST,PRCST1,SPENDCP,STRING,TEST
 K %W,D0,DIW,DIWI,DIWT,DIWTC,DIWX,DN,OK,P1,PRCNJ,PRCSCP,PRCSERR,UTYP
 K PRCSPG,PRCSQT,RECORD,RECORD1,RECORD10,RECORD2,RECORD3,RECORD4
 K SKIPRNT,STKNO,TDA,TRNODE,XNAME,JUMP,POP,PRCSCST,QFL,PDD1,SRTGRP
 Q
LINE ; Line item copier, called from [PRCN2237] input template
 ;NEW DIEL,Y,DG,DI,DK,DL,DM,DP,DU,D0,D1,DA,DIC,DIE,DR,DOV
CPLINE ; Create a line item in 2237 and copy over line item from request
 N I S (I,C)=0 F  S I=$O(^PRCN(413,TDA,1,"B",I)) Q:I'>0  S C=C+1
 S DA=0 F  S DA=$O(^PRCN(413,TDA,1,DA)) Q:'DA  S LI=DA D L2 D  Q:$D(DUOUT)
 . W !!,"Line Item #",DA,":",!,"Description:"
 . F II=1:1 Q:'$D(^PRCN(413,IN,1,LI,1,II))  S DL=^(II,0) D
 .. W !,"    ",DL S ^PRCS(410,DA(1),"IT",LI,1,II,0)=DL
 . W ! S ^PRCS(410,DA(1),"IT",LI,1,0)="^^"_(II-1)_U_(II-1)_U_DT
 . I $P(^PRCN(413,IN,1,LI,0),U,12)="P",$P(^(0),U,2)'="" S PRCNVNDR=$P(^(0),U,2)
 . I $G(PRCNVNDR)="" S PRCNVNDR=$P(^PRCN(413,IN,1,LI,0),U,13)
 . D ^DIC Q:$G(DUOUT)=1!($G(DTOUT)=1)  D ^DIE
 K C,DLAYGO,DL,II,LI
 Q
L2 S DA(1)=PRCNT1,DIC(0)="LZ",DLAYGO=410,X=DA
 S (DIE,DIC)="^PRCS(410,"_DA(1)_",""IT"","
 I '$D(@(DIC_"0)")) S @(DIC_"0)")="^410.02AI^0^0"
 D FILE^DICN
 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))
 S COST=$P(^PRCN(413,IN,1,LI,0),U,4),STKNO=$P(^(0),U,3)
 ; Special DRs to automatically copy line items from request
 S UTYP=$O(^PRCD(420.5,"B","EA","")) S:UTYP="" UTYP="EA"
 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]"""
 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;"
 Q
CMP ;  Check for completeness of data
 S PDD1=0 F  S PDD1=$O(^PRCS(410,D0,"IT",PDD1)) Q:'PDD1  D CMPD Q:QFL
 Q
CMPD S QFL=0 F I=1,2,3,4,7 I $P(^PRCS(410,D0,"IT",PDD1,0),U,I)="" S QFL=1
 Q