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 Dec 13, 2024@01:54:10 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
