PRCNSPL ;SSI/SEB-Split a request ;[ 09/09/96 10:43 AM ]
;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
S DIC("S")="S ST=$P(^(0),U,7) I ST=1!(ST=4)!(ST=11)!(ST=12)!(ST=14)!(ST=15)!(ST=16)!(ST=17)!(ST=29)!(ST=37)!(ST=40)&($P(^(0),U,2)=DUZ)"
S DIC="^PRCN(413,",DIC(0)="AEQZ" D ^DIC G:Y<0 EXIT S DA=+Y K DIC("S")
S PTRN=$P(^PRCN(413,DA,0),U)
INIT S N=413.015,PRCNUSR=($P(^PRCN(413,DA,0),U,7)>1),(FF,NL,IN)=0
S GLO=DIC_DA_",1,",PRCNDEEP=1,PROG="PRNT" D:'$D(IOT) HOME^%ZIS
S DIC="^PRCN(413,"
LOOP G:$D(NEW) NEW S (II,JJ)=0
F S IN=$O(^PRCN(413,DA,1,IN)) Q:'+IN!($D(DUOUT)) W ! D SUBS^PRCNPRNT,ASK
K PRCNDEEP,N,FN,PRFLD,PRCNUSR
G:$D(DUOUT) EXIT
I '$D(NEW) W $C(7),!!,"You didn't select any line items! Request not split." G EXIT
I II=$P(^PRCN(413,DA,1,0),U,4) W $C(7),!!,"You selected all of the line items! Request not split." G EXIT
S IN=DA
NEW ; Get new request # and build a new request
G:$D(DUOUT) EXIT
W !!,"Splitting this request. Please wait..."
D FSF S ODA=IN
S X=PTRN_SUF W !,"NEW TRANSACTION NUMBER: ",X S NTRN=X
S DIC="^PRCN(413,",DIC(0)="LQZ",DLAYGO=413 D FILE^DICN Q:+Y<1 S (NDA,DA)=+Y
S $P(^PRCN(413,DA,0),U,2,99)=$P(^PRCN(413,ODA,0),U,2,99)
S GL="^PRCN(413,"_ODA_",1.9)"
F S GL=$Q(@GL) Q:GL'[("413,"_ODA) S @("^PRCN(413,"_DA_","_$P(GL,",",3,99))=@GL
LINE ; Copy over line items, remove line items from orig. request
F PRCNI=1:1 S PRCNJ=$P(NEW,U,PRCNI) Q:PRCNJ="" D
. I $G(^PRCN(413,NDA,1,0))="" S ^PRCN(413,NDA,1,0)="^413.015A^^"
. S X=$P(^PRCN(413,ODA,1,PRCNJ,0),U),DLAYGO=413.015,DIC(0)="L",DA(1)=NDA
. S DIC="^PRCN(413,"_DA(1)_",1," D FILE^DICN S DA=+Y
. S %X="^PRCN(413,"_ODA_",1,"_PRCNJ_",",%Y="^PRCN(413,"_DA(1)_",1,"_DA_","
. D %XY^%RCR
S DA(1)=ODA,DIK="^PRCN(413,"_DA(1)_",1,"
F PRCNI=1:1 S PRCNJ=$P(NEW,U,PRCNI) Q:'PRCNJ S DA=PRCNJ D ^DIK
S X=$P(^PRCN(413,ODA,2),U,18) D
. D:'$D(PSER) PRIMAX^PRCNCMRP
. S RNK="" F S RNK=$O(^PRCN(413,"P",PSER,RNK)) Q:RNK="" K ^PRCN(413,"P",PSER,RNK,ODA)
. K PSER,X,RNK,LPRI,II,PRIMAX
S X=$P(^PRCN(413,NDA,2),U,18) D
. D:'$D(PSER) PRIMAX^PRCNCMRP
. S RNK="" F S RNK=$O(^PRCN(413,"P",PSER,RNK)) Q:RNK="" K ^PRCN(413,"P",PSER,RNK,NDA)
. K PSER,X,RNK,LPRI,II,PRIMAX
MKREP D:$P(^PRCN(413,ODA,0),U,9)="R" REPL
EXIT K DUOUT,II,JJ,TST,REQ,PRCNDEL,DIC,IEXP,IEXN,PI,ODA,ORDA,PRCNJ,PRCNI
K C,CODES,D0,DA,FF,GLO,I,ID,J,N2,NEW,NL,OGLO,OID,OIN,OPC,PC,PGL
K PRCNDD,PROG,PTRN,PV,ST,X,Y,VAL,V,%,%Y
Q
REPL ; Split replacement request
S ORDA=$P(^PRCN(413,ODA,0),U,11),REQ=$P(^PRCN(413.1,ORDA,0),U),TST=$P(REQ,"-",1,3)
NEW NDA D SEQ^PRCNUTL S TST=TST_"-" S:REQ["P" TST=TST_"P"
S DIC="^PRCN(413.1,"
S DLAYGO=413.1,X=TST_$E("00000",$L(PRCNDA)+1,5)_PRCNDA_SUF D ^DIC Q:Y<0
S RDA=+Y,GL="^PRCN(413.1,"_ORDA_",1.9)",II=1,(I,J,JJ)=0,PRCNDEL=""
S $P(^PRCN(413.1,RDA,0),U,2)=$P(^PRCN(413.1,ORDA,0),U,2,99)
S $P(^PRCN(413.1,RDA,0),U,9)=DA,$P(^PRCN(413,DA,0),U,11)=RDA
F S GL=$Q(@GL) Q:GL'[("413.1,"_ORDA) D
. S @("^PRCN(413.1,"_RDA_","_$P(GL,",",3,99))=@GL
REPLINE F I=1:1 S II=$P(NEW,U,I) Q:II="" D
. S JJ=0 F S JJ=$O(^PRCN(413.1,ORDA,1,JJ)) Q:'+JJ D
.. I $P(^PRCN(413.1,ORDA,1,JJ,0),U,3)'=II S:$P(PRCNDEL,U,JJ)'=0 $P(PRCNDEL,U,JJ)=1 Q
.. S J=J+1,^PRCN(413.1,RDA,1,J,0)=^PRCN(413.1,ORDA,1,JJ,0),TI=+^(0)
.. S $P(^PRCN(413.1,RDA,1,J,0),U,3)=I,$P(PRCNDEL,U,JJ)=0
.. S ^PRCN(413.1,RDA,1,"B",TI,J)=""
S ^PRCN(413.1,RDA,1,0)="^413.11IPA^"_J_U_J Q:OLD=""
REPDEL ; Compress unmoved items and delete moved line items in orig. request
S L=0,O=1 F I=1:1 S II=$P(PRCNDEL,U,I) Q:II="" S:O&('II) L=I D S O=II
. I II&(O'=II) S $P(PRCNDEL,U,I)=0,$P(PRCNDEL,U,L)=1,I=L D
.. S ^PRCN(413.1,ORDA,1,L,0)=^PRCN(413.1,ORDA,1,I,0)
.. S $P(^PRCN(413.1,ORDA,1,L,0),U,3)=L
Q:L<1 F J=L:1:I-1 S LI=+^PRCN(413.1,ORDA,1,J,0) D
. K ^PRCN(413.1,ORDA,1,"B",LI,J),^PRCN(413.1,ORDA,1,J)
Q
ASK S %=1 W !!,"Transfer this line item to the new request" D YN^DICN
S:%=-1 DUOUT=1 I %=0 W !,"Answer 'Y' for yes, and 'N' for no." G ASK
S:%=1 II=II+1,$P(NEW,U,II)=IN S:%=2 JJ=JJ+1,$P(OLD,U,JJ)=IN
Q
FSF ; Find new transaction number
S SUF="",SFL=0
F BSF=65:1:90 S TTRN=PTRN_$C(BSF) D Q:SFL=1
. I '$D(^PRCN(413,"B",TTRN)) S SFL=1,SUF=$C(BSF) Q
K TTRN,BSF,SFL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCNSPL 4207 printed Oct 16, 2024@17:55:27 Page 2
PRCNSPL ;SSI/SEB-Split a request ;[ 09/09/96 10:43 AM ]
+1 ;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
+2 SET DIC("S")="S ST=$P(^(0),U,7) I ST=1!(ST=4)!(ST=11)!(ST=12)!(ST=14)!(ST=15)!(ST=16)!(ST=17)!(ST=29)!(ST=37)!(ST=40)&($P(^(0),U,2)=DUZ)"
+3 SET DIC="^PRCN(413,"
SET DIC(0)="AEQZ"
DO ^DIC
if Y<0
GOTO EXIT
SET DA=+Y
KILL DIC("S")
+4 SET PTRN=$PIECE(^PRCN(413,DA,0),U)
INIT SET N=413.015
SET PRCNUSR=($PIECE(^PRCN(413,DA,0),U,7)>1)
SET (FF,NL,IN)=0
+1 SET GLO=DIC_DA_",1,"
SET PRCNDEEP=1
SET PROG="PRNT"
if '$DATA(IOT)
DO HOME^%ZIS
+2 SET DIC="^PRCN(413,"
LOOP if $DATA(NEW)
GOTO NEW
SET (II,JJ)=0
+1 FOR
SET IN=$ORDER(^PRCN(413,DA,1,IN))
if '+IN!($DATA(DUOUT))
QUIT
WRITE !
DO SUBS^PRCNPRNT
DO ASK
+2 KILL PRCNDEEP,N,FN,PRFLD,PRCNUSR
+3 if $DATA(DUOUT)
GOTO EXIT
+4 IF '$DATA(NEW)
WRITE $CHAR(7),!!,"You didn't select any line items! Request not split."
GOTO EXIT
+5 IF II=$PIECE(^PRCN(413,DA,1,0),U,4)
WRITE $CHAR(7),!!,"You selected all of the line items! Request not split."
GOTO EXIT
+6 SET IN=DA
NEW ; Get new request # and build a new request
+1 if $DATA(DUOUT)
GOTO EXIT
+2 WRITE !!,"Splitting this request. Please wait..."
+3 DO FSF
SET ODA=IN
+4 SET X=PTRN_SUF
WRITE !,"NEW TRANSACTION NUMBER: ",X
SET NTRN=X
+5 SET DIC="^PRCN(413,"
SET DIC(0)="LQZ"
SET DLAYGO=413
DO FILE^DICN
if +Y<1
QUIT
SET (NDA,DA)=+Y
+6 SET $PIECE(^PRCN(413,DA,0),U,2,99)=$PIECE(^PRCN(413,ODA,0),U,2,99)
+7 SET GL="^PRCN(413,"_ODA_",1.9)"
+8 FOR
SET GL=$QUERY(@GL)
if GL'[("413,"_ODA)
QUIT
SET @("^PRCN(413,"_DA_","_$PIECE(GL,",",3,99))=@GL
LINE ; Copy over line items, remove line items from orig. request
+1 FOR PRCNI=1:1
SET PRCNJ=$PIECE(NEW,U,PRCNI)
if PRCNJ=""
QUIT
Begin DoDot:1
+2 IF $GET(^PRCN(413,NDA,1,0))=""
SET ^PRCN(413,NDA,1,0)="^413.015A^^"
+3 SET X=$PIECE(^PRCN(413,ODA,1,PRCNJ,0),U)
SET DLAYGO=413.015
SET DIC(0)="L"
SET DA(1)=NDA
+4 SET DIC="^PRCN(413,"_DA(1)_",1,"
DO FILE^DICN
SET DA=+Y
+5 SET %X="^PRCN(413,"_ODA_",1,"_PRCNJ_","
SET %Y="^PRCN(413,"_DA(1)_",1,"_DA_","
+6 DO %XY^%RCR
End DoDot:1
+7 SET DA(1)=ODA
SET DIK="^PRCN(413,"_DA(1)_",1,"
+8 FOR PRCNI=1:1
SET PRCNJ=$PIECE(NEW,U,PRCNI)
if 'PRCNJ
QUIT
SET DA=PRCNJ
DO ^DIK
+9 SET X=$PIECE(^PRCN(413,ODA,2),U,18)
Begin DoDot:1
+10 if '$DATA(PSER)
DO PRIMAX^PRCNCMRP
+11 SET RNK=""
FOR
SET RNK=$ORDER(^PRCN(413,"P",PSER,RNK))
if RNK=""
QUIT
KILL ^PRCN(413,"P",PSER,RNK,ODA)
+12 KILL PSER,X,RNK,LPRI,II,PRIMAX
End DoDot:1
+13 SET X=$PIECE(^PRCN(413,NDA,2),U,18)
Begin DoDot:1
+14 if '$DATA(PSER)
DO PRIMAX^PRCNCMRP
+15 SET RNK=""
FOR
SET RNK=$ORDER(^PRCN(413,"P",PSER,RNK))
if RNK=""
QUIT
KILL ^PRCN(413,"P",PSER,RNK,NDA)
+16 KILL PSER,X,RNK,LPRI,II,PRIMAX
End DoDot:1
MKREP if $PIECE(^PRCN(413,ODA,0),U,9)="R"
DO REPL
EXIT KILL DUOUT,II,JJ,TST,REQ,PRCNDEL,DIC,IEXP,IEXN,PI,ODA,ORDA,PRCNJ,PRCNI
+1 KILL C,CODES,D0,DA,FF,GLO,I,ID,J,N2,NEW,NL,OGLO,OID,OIN,OPC,PC,PGL
+2 KILL PRCNDD,PROG,PTRN,PV,ST,X,Y,VAL,V,%,%Y
+3 QUIT
REPL ; Split replacement request
+1 SET ORDA=$PIECE(^PRCN(413,ODA,0),U,11)
SET REQ=$PIECE(^PRCN(413.1,ORDA,0),U)
SET TST=$PIECE(REQ,"-",1,3)
+2 NEW NDA
DO SEQ^PRCNUTL
SET TST=TST_"-"
if REQ["P"
SET TST=TST_"P"
+3 SET DIC="^PRCN(413.1,"
+4 SET DLAYGO=413.1
SET X=TST_$EXTRACT("00000",$LENGTH(PRCNDA)+1,5)_PRCNDA_SUF
DO ^DIC
if Y<0
QUIT
+5 SET RDA=+Y
SET GL="^PRCN(413.1,"_ORDA_",1.9)"
SET II=1
SET (I,J,JJ)=0
SET PRCNDEL=""
+6 SET $PIECE(^PRCN(413.1,RDA,0),U,2)=$PIECE(^PRCN(413.1,ORDA,0),U,2,99)
+7 SET $PIECE(^PRCN(413.1,RDA,0),U,9)=DA
SET $PIECE(^PRCN(413,DA,0),U,11)=RDA
+8 FOR
SET GL=$QUERY(@GL)
if GL'[("413.1,"_ORDA)
QUIT
Begin DoDot:1
+9 SET @("^PRCN(413.1,"_RDA_","_$PIECE(GL,",",3,99))=@GL
End DoDot:1
REPLINE FOR I=1:1
SET II=$PIECE(NEW,U,I)
if II=""
QUIT
Begin DoDot:1
+1 SET JJ=0
FOR
SET JJ=$ORDER(^PRCN(413.1,ORDA,1,JJ))
if '+JJ
QUIT
Begin DoDot:2
+2 IF $PIECE(^PRCN(413.1,ORDA,1,JJ,0),U,3)'=II
if $PIECE(PRCNDEL,U,JJ)'=0
SET $PIECE(PRCNDEL,U,JJ)=1
QUIT
+3 SET J=J+1
SET ^PRCN(413.1,RDA,1,J,0)=^PRCN(413.1,ORDA,1,JJ,0)
SET TI=+^(0)
+4 SET $PIECE(^PRCN(413.1,RDA,1,J,0),U,3)=I
SET $PIECE(PRCNDEL,U,JJ)=0
+5 SET ^PRCN(413.1,RDA,1,"B",TI,J)=""
End DoDot:2
End DoDot:1
+6 SET ^PRCN(413.1,RDA,1,0)="^413.11IPA^"_J_U_J
if OLD=""
QUIT
REPDEL ; Compress unmoved items and delete moved line items in orig. request
+1 SET L=0
SET O=1
FOR I=1:1
SET II=$PIECE(PRCNDEL,U,I)
if II=""
QUIT
if O&('II)
SET L=I
Begin DoDot:1
+2 IF II&(O'=II)
SET $PIECE(PRCNDEL,U,I)=0
SET $PIECE(PRCNDEL,U,L)=1
SET I=L
Begin DoDot:2
+3 SET ^PRCN(413.1,ORDA,1,L,0)=^PRCN(413.1,ORDA,1,I,0)
+4 SET $PIECE(^PRCN(413.1,ORDA,1,L,0),U,3)=L
End DoDot:2
End DoDot:1
SET O=II
+5 if L<1
QUIT
FOR J=L:1:I-1
SET LI=+^PRCN(413.1,ORDA,1,J,0)
Begin DoDot:1
+6 KILL ^PRCN(413.1,ORDA,1,"B",LI,J),^PRCN(413.1,ORDA,1,J)
End DoDot:1
+7 QUIT
ASK SET %=1
WRITE !!,"Transfer this line item to the new request"
DO YN^DICN
+1 if %=-1
SET DUOUT=1
IF %=0
WRITE !,"Answer 'Y' for yes, and 'N' for no."
GOTO ASK
+2 if %=1
SET II=II+1
SET $PIECE(NEW,U,II)=IN
if %=2
SET JJ=JJ+1
SET $PIECE(OLD,U,JJ)=IN
+3 QUIT
FSF ; Find new transaction number
+1 SET SUF=""
SET SFL=0
+2 FOR BSF=65:1:90
SET TTRN=PTRN_$CHAR(BSF)
Begin DoDot:1
+3 IF '$DATA(^PRCN(413,"B",TTRN))
SET SFL=1
SET SUF=$CHAR(BSF)
QUIT
End DoDot:1
if SFL=1
QUIT
+4 KILL TTRN,BSF,SFL
+5 QUIT
