Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCNSPL

PRCNSPL.m

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