- 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 Feb 18, 2025@23:21:02 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