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