PRCNEQA1 ;SSI/ALA-Equipment Committee Approval ;[ 09/09/96 3:15 PM ]
;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
FAP ;
S PRCNDIS=1 D LINE
QS K % W !!,"Does request need a final confirmation from responsible CMR Official"
D YN^DICN
I %=0 D G QS
. W !,"Enter 'Yes' if this request is to be sent to the CMR Offical for a final review"
. W !,"before a 2237 is to be created. Enter 'No' if a 2237 should be created without"
. W !,"further review."
I %=1 D MSG
I %<0 S DUOUT=1 Q
S DIC="^PRCN(413,",DIE=DIC,(DA,D0)=IN
S DR="6////^S X=STAT;7////^S X=DT;47////^S X=STT;48////^S X=DT;49///@" D ^DIE
S MSGN=$S(EQXI=1:43,EQXI=2:44,EQXI=3:40,EQXI=4:39,1:"")
D MES^PRCNMESG
S D1=0 F S D1=$O(^PRCN(413,D0,1,D1)) Q:D1'>0 S QTY=$P(^(D1,0),U,5) D ^DIE
I EQXI>2 G AXT
AXT K DIC,DIE,DR,EANS,%,QTY,D0,D1,DA,PRCNDIS
Q
LINE ; Display line item information
W !!,"TRANSACTION #: ",$P(^PRCN(413,IN,0),U)
S OIN2=$P(^PRCN(413,IN,1,0),U,3)
F IN2=1:1:OIN2 D Q:$D(DUOUT)
. Q:$G(^PRCN(413,IN,1,IN2,0))=""
. S REQ=$P(^PRCN(413,IN,1,IN2,0),U,5),LST=""
. S PRCNI=IN,(PRCNJ,PRCNK)=IN2,APP=$S(REQ="":0,1:REQ)
. S QTY=$P(^PRCN(413,PRCNI,1,PRCNJ,0),U,5),PR=$P(^(0),U,4)
. W !!,"Qty: ",QTY,?20,"Price: ",PR,?40,"Total: ",QTY*PR,!,"Description:"
. S PRCNL=0 F S PRCNL=$O(^PRCN(413,PRCNI,1,PRCNJ,1,PRCNL)) Q:'+PRCNL W !," ",^(PRCNL,0)
. I $G(PRCNDIS)="" D LINE2
K OIN2,REQ,QTY,APP,LAPP,DR,PR,DIC,DA,D0,D1,PRCNI,PRCNL,PRCNJ,PRCNK
K DIR,ST,PRCNN,DLAYGO,LST
Q
LINE2 ; Display line item & get input
S DIR(0)="S^AF:Approved and Funded;AP:Approved Pending Funds;DD:Disapproved;DF:Deferred until later"
S DIR("A")="Select a status code" D ^DIR Q:$G(DIRUT)=1
S ST=Y
; Decide on actual quantity being decided, may not be same as the
; requested quantity
QUAN W !,"Quantity requested: ",REQ
W ?40,"Quantity approved: ",APP,"//" R PRCNN:DTIME I '$T G QUAN
I PRCNN["?" D G QUAN
. W !!,"Enter a numeric quantity that is being approved. It"
. W !,"does not have to be the same as the requested quantity."
S:PRCNN="^" DUOUT="^" Q:$D(DUOUT)
S:PRCNN="" PRCNN=APP S:LST="" LST=ST
I PRCNN>APP!(PRCNN<1)!(PRCNN'?.N) W $C(7) G QUAN
I ST'=LST D SPLIT S LST=ST
I ST=LST S DA=PRCNJ,DA(1)=PRCNI D UPDT
S LAPP=APP-PRCNN Q:LAPP=0 S APP=LAPP
G LINE2
UPDT ; Update the line item/transaction
S DR="10////^S X=ST;12////^S X=DT;9////^S X=PRCNN"
S:ST["D" DR=DR_";11;I '$D(^PRCN(413,DA(1),1,DA,3)) W $C(7),!,""Explanation is required!"" S Y=11"
S (DIC,DIE)="^PRCN(413,"_DA(1)_",1," D ^DIE
Q
SPLIT ; Split line item based on quantity approved
S DA(1)=PRCNI,X=$P(^PRCN(413,DA(1),1,PRCNJ,0),U),DIC(0)="L"
S DIC="^PRCN(413,"_DA(1)_",1,",DLAYGO=413.015
D FILE^DICN S (PRCNJ,DA)=+Y D COPY
S DR=".01////^S X=PRCNJ",DIE=DIC D ^DIE
Q
EXIT K DIC,DIE,DA,%
Q
COPY ; Copy data from one line item to new line item
S %X="^PRCN(413,"_PRCNI_",1,"_PRCNK_",",%Y="^PRCN(413,"_PRCNI_",1,"_PRCNJ_","
D %XY^%RCR
K %X,%Y
Q
MSG ; Send message to CMR Official for final confirmation
S MSGN=53 K NOD
; set transaction data into message
D MES^PRCNMESG
S DIC="^PRCN(413,",DIE=DIC,(DA,D0)=IN
S DR="6////^S X=45;7////^S X=DT" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNEQA1 3192 printed Apr 09, 2024@20:59:35 Page 2
PRCNEQA1 ;SSI/ALA-Equipment Committee Approval ;[ 09/09/96 3:15 PM ]
+1 ;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
FAP ;
+1 SET PRCNDIS=1
DO LINE
QS KILL %
WRITE !!,"Does request need a final confirmation from responsible CMR Official"
+1 DO YN^DICN
+2 IF %=0
Begin DoDot:1
+3 WRITE !,"Enter 'Yes' if this request is to be sent to the CMR Offical for a final review"
+4 WRITE !,"before a 2237 is to be created. Enter 'No' if a 2237 should be created without"
+5 WRITE !,"further review."
End DoDot:1
GOTO QS
+6 IF %=1
DO MSG
+7 IF %<0
SET DUOUT=1
QUIT
+8 SET DIC="^PRCN(413,"
SET DIE=DIC
SET (DA,D0)=IN
+9 SET DR="6////^S X=STAT;7////^S X=DT;47////^S X=STT;48////^S X=DT;49///@"
DO ^DIE
+10 SET MSGN=$SELECT(EQXI=1:43,EQXI=2:44,EQXI=3:40,EQXI=4:39,1:"")
+11 DO MES^PRCNMESG
+12 SET D1=0
FOR
SET D1=$ORDER(^PRCN(413,D0,1,D1))
if D1'>0
QUIT
SET QTY=$PIECE(^(D1,0),U,5)
DO ^DIE
+13 IF EQXI>2
GOTO AXT
AXT KILL DIC,DIE,DR,EANS,%,QTY,D0,D1,DA,PRCNDIS
+1 QUIT
LINE ; Display line item information
+1 WRITE !!,"TRANSACTION #: ",$PIECE(^PRCN(413,IN,0),U)
+2 SET OIN2=$PIECE(^PRCN(413,IN,1,0),U,3)
+3 FOR IN2=1:1:OIN2
Begin DoDot:1
+4 if $GET(^PRCN(413,IN,1,IN2,0))=""
QUIT
+5 SET REQ=$PIECE(^PRCN(413,IN,1,IN2,0),U,5)
SET LST=""
+6 SET PRCNI=IN
SET (PRCNJ,PRCNK)=IN2
SET APP=$SELECT(REQ="":0,1:REQ)
+7 SET QTY=$PIECE(^PRCN(413,PRCNI,1,PRCNJ,0),U,5)
SET PR=$PIECE(^(0),U,4)
+8 WRITE !!,"Qty: ",QTY,?20,"Price: ",PR,?40,"Total: ",QTY*PR,!,"Description:"
+9 SET PRCNL=0
FOR
SET PRCNL=$ORDER(^PRCN(413,PRCNI,1,PRCNJ,1,PRCNL))
if '+PRCNL
QUIT
WRITE !," ",^(PRCNL,0)
+10 IF $GET(PRCNDIS)=""
DO LINE2
End DoDot:1
if $DATA(DUOUT)
QUIT
+11 KILL OIN2,REQ,QTY,APP,LAPP,DR,PR,DIC,DA,D0,D1,PRCNI,PRCNL,PRCNJ,PRCNK
+12 KILL DIR,ST,PRCNN,DLAYGO,LST
+13 QUIT
LINE2 ; Display line item & get input
+1 SET DIR(0)="S^AF:Approved and Funded;AP:Approved Pending Funds;DD:Disapproved;DF:Deferred until later"
+2 SET DIR("A")="Select a status code"
DO ^DIR
if $GET(DIRUT)=1
QUIT
+3 SET ST=Y
+4 ; Decide on actual quantity being decided, may not be same as the
+5 ; requested quantity
QUAN WRITE !,"Quantity requested: ",REQ
+1 WRITE ?40,"Quantity approved: ",APP,"//"
READ PRCNN:DTIME
IF '$TEST
GOTO QUAN
+2 IF PRCNN["?"
Begin DoDot:1
+3 WRITE !!,"Enter a numeric quantity that is being approved. It"
+4 WRITE !,"does not have to be the same as the requested quantity."
End DoDot:1
GOTO QUAN
+5 if PRCNN="^"
SET DUOUT="^"
if $DATA(DUOUT)
QUIT
+6 if PRCNN=""
SET PRCNN=APP
if LST=""
SET LST=ST
+7 IF PRCNN>APP!(PRCNN<1)!(PRCNN'?.N)
WRITE $CHAR(7)
GOTO QUAN
+8 IF ST'=LST
DO SPLIT
SET LST=ST
+9 IF ST=LST
SET DA=PRCNJ
SET DA(1)=PRCNI
DO UPDT
+10 SET LAPP=APP-PRCNN
if LAPP=0
QUIT
SET APP=LAPP
+11 GOTO LINE2
UPDT ; Update the line item/transaction
+1 SET DR="10////^S X=ST;12////^S X=DT;9////^S X=PRCNN"
+2 if ST["D"
SET DR=DR_";11;I '$D(^PRCN(413,DA(1),1,DA,3)) W $C(7),!,""Explanation is required!"" S Y=11"
+3 SET (DIC,DIE)="^PRCN(413,"_DA(1)_",1,"
DO ^DIE
+4 QUIT
SPLIT ; Split line item based on quantity approved
+1 SET DA(1)=PRCNI
SET X=$PIECE(^PRCN(413,DA(1),1,PRCNJ,0),U)
SET DIC(0)="L"
+2 SET DIC="^PRCN(413,"_DA(1)_",1,"
SET DLAYGO=413.015
+3 DO FILE^DICN
SET (PRCNJ,DA)=+Y
DO COPY
+4 SET DR=".01////^S X=PRCNJ"
SET DIE=DIC
DO ^DIE
+5 QUIT
EXIT KILL DIC,DIE,DA,%
+1 QUIT
COPY ; Copy data from one line item to new line item
+1 SET %X="^PRCN(413,"_PRCNI_",1,"_PRCNK_","
SET %Y="^PRCN(413,"_PRCNI_",1,"_PRCNJ_","
+2 DO %XY^%RCR
+3 KILL %X,%Y
+4 QUIT
MSG ; Send message to CMR Official for final confirmation
+1 SET MSGN=53
KILL NOD
+2 ; set transaction data into message
+3 DO MES^PRCNMESG
+4 SET DIC="^PRCN(413,"
SET DIE=DIC
SET (DA,D0)=IN
+5 SET DR="6////^S X=45;7////^S X=DT"
DO ^DIE
+6 QUIT
