source: WorldVistAEHR/trunk/r/EQUIPMENT_TURN_IN_REQUEST-PRCN/PRCNSPL.m@ 1504

Last change on this file since 1504 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
RevLine 
[613]1PRCNSPL ;SSI/SEB-Split a request ;[ 09/09/96 10:43 AM ]
2 ;;1.0;Equipment/Turn-In Request;;Sep 13, 1996
3 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)"
4 S DIC="^PRCN(413,",DIC(0)="AEQZ" D ^DIC G:Y<0 EXIT S DA=+Y K DIC("S")
5 S PTRN=$P(^PRCN(413,DA,0),U)
6INIT S N=413.015,PRCNUSR=($P(^PRCN(413,DA,0),U,7)>1),(FF,NL,IN)=0
7 S GLO=DIC_DA_",1,",PRCNDEEP=1,PROG="PRNT" D:'$D(IOT) HOME^%ZIS
8 S DIC="^PRCN(413,"
9LOOP G:$D(NEW) NEW S (II,JJ)=0
10 F S IN=$O(^PRCN(413,DA,1,IN)) Q:'+IN!($D(DUOUT)) W ! D SUBS^PRCNPRNT,ASK
11 K PRCNDEEP,N,FN,PRFLD,PRCNUSR
12 G:$D(DUOUT) EXIT
13 I '$D(NEW) W $C(7),!!,"You didn't select any line items! Request not split." G EXIT
14 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
15 S IN=DA
16NEW ; Get new request # and build a new request
17 G:$D(DUOUT) EXIT
18 W !!,"Splitting this request. Please wait..."
19 D FSF S ODA=IN
20 S X=PTRN_SUF W !,"NEW TRANSACTION NUMBER: ",X S NTRN=X
21 S DIC="^PRCN(413,",DIC(0)="LQZ",DLAYGO=413 D FILE^DICN Q:+Y<1 S (NDA,DA)=+Y
22 S $P(^PRCN(413,DA,0),U,2,99)=$P(^PRCN(413,ODA,0),U,2,99)
23 S GL="^PRCN(413,"_ODA_",1.9)"
24 F S GL=$Q(@GL) Q:GL'[("413,"_ODA) S @("^PRCN(413,"_DA_","_$P(GL,",",3,99))=@GL
25LINE ; Copy over line items, remove line items from orig. request
26 F PRCNI=1:1 S PRCNJ=$P(NEW,U,PRCNI) Q:PRCNJ="" D
27 . I $G(^PRCN(413,NDA,1,0))="" S ^PRCN(413,NDA,1,0)="^413.015A^^"
28 . S X=$P(^PRCN(413,ODA,1,PRCNJ,0),U),DLAYGO=413.015,DIC(0)="L",DA(1)=NDA
29 . S DIC="^PRCN(413,"_DA(1)_",1," D FILE^DICN S DA=+Y
30 . S %X="^PRCN(413,"_ODA_",1,"_PRCNJ_",",%Y="^PRCN(413,"_DA(1)_",1,"_DA_","
31 . D %XY^%RCR
32 S DA(1)=ODA,DIK="^PRCN(413,"_DA(1)_",1,"
33 F PRCNI=1:1 S PRCNJ=$P(NEW,U,PRCNI) Q:'PRCNJ S DA=PRCNJ D ^DIK
34 S X=$P(^PRCN(413,ODA,2),U,18) D
35 . D:'$D(PSER) PRIMAX^PRCNCMRP
36 . S RNK="" F S RNK=$O(^PRCN(413,"P",PSER,RNK)) Q:RNK="" K ^PRCN(413,"P",PSER,RNK,ODA)
37 . K PSER,X,RNK,LPRI,II,PRIMAX
38 S X=$P(^PRCN(413,NDA,2),U,18) D
39 . D:'$D(PSER) PRIMAX^PRCNCMRP
40 . S RNK="" F S RNK=$O(^PRCN(413,"P",PSER,RNK)) Q:RNK="" K ^PRCN(413,"P",PSER,RNK,NDA)
41 . K PSER,X,RNK,LPRI,II,PRIMAX
42MKREP D:$P(^PRCN(413,ODA,0),U,9)="R" REPL
43EXIT K DUOUT,II,JJ,TST,REQ,PRCNDEL,DIC,IEXP,IEXN,PI,ODA,ORDA,PRCNJ,PRCNI
44 K C,CODES,D0,DA,FF,GLO,I,ID,J,N2,NEW,NL,OGLO,OID,OIN,OPC,PC,PGL
45 K PRCNDD,PROG,PTRN,PV,ST,X,Y,VAL,V,%,%Y
46 Q
47REPL ; Split replacement request
48 S ORDA=$P(^PRCN(413,ODA,0),U,11),REQ=$P(^PRCN(413.1,ORDA,0),U),TST=$P(REQ,"-",1,3)
49 NEW NDA D SEQ^PRCNUTL S TST=TST_"-" S:REQ["P" TST=TST_"P"
50 S DIC="^PRCN(413.1,"
51 S DLAYGO=413.1,X=TST_$E("00000",$L(PRCNDA)+1,5)_PRCNDA_SUF D ^DIC Q:Y<0
52 S RDA=+Y,GL="^PRCN(413.1,"_ORDA_",1.9)",II=1,(I,J,JJ)=0,PRCNDEL=""
53 S $P(^PRCN(413.1,RDA,0),U,2)=$P(^PRCN(413.1,ORDA,0),U,2,99)
54 S $P(^PRCN(413.1,RDA,0),U,9)=DA,$P(^PRCN(413,DA,0),U,11)=RDA
55 F S GL=$Q(@GL) Q:GL'[("413.1,"_ORDA) D
56 . S @("^PRCN(413.1,"_RDA_","_$P(GL,",",3,99))=@GL
57REPLINE F I=1:1 S II=$P(NEW,U,I) Q:II="" D
58 . S JJ=0 F S JJ=$O(^PRCN(413.1,ORDA,1,JJ)) Q:'+JJ D
59 .. I $P(^PRCN(413.1,ORDA,1,JJ,0),U,3)'=II S:$P(PRCNDEL,U,JJ)'=0 $P(PRCNDEL,U,JJ)=1 Q
60 .. S J=J+1,^PRCN(413.1,RDA,1,J,0)=^PRCN(413.1,ORDA,1,JJ,0),TI=+^(0)
61 .. S $P(^PRCN(413.1,RDA,1,J,0),U,3)=I,$P(PRCNDEL,U,JJ)=0
62 .. S ^PRCN(413.1,RDA,1,"B",TI,J)=""
63 S ^PRCN(413.1,RDA,1,0)="^413.11IPA^"_J_U_J Q:OLD=""
64REPDEL ; Compress unmoved items and delete moved line items in orig. request
65 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
66 . I II&(O'=II) S $P(PRCNDEL,U,I)=0,$P(PRCNDEL,U,L)=1,I=L D
67 .. S ^PRCN(413.1,ORDA,1,L,0)=^PRCN(413.1,ORDA,1,I,0)
68 .. S $P(^PRCN(413.1,ORDA,1,L,0),U,3)=L
69 Q:L<1 F J=L:1:I-1 S LI=+^PRCN(413.1,ORDA,1,J,0) D
70 . K ^PRCN(413.1,ORDA,1,"B",LI,J),^PRCN(413.1,ORDA,1,J)
71 Q
72ASK S %=1 W !!,"Transfer this line item to the new request" D YN^DICN
73 S:%=-1 DUOUT=1 I %=0 W !,"Answer 'Y' for yes, and 'N' for no." G ASK
74 S:%=1 II=II+1,$P(NEW,U,II)=IN S:%=2 JJ=JJ+1,$P(OLD,U,JJ)=IN
75 Q
76FSF ; Find new transaction number
77 S SUF="",SFL=0
78 F BSF=65:1:90 S TTRN=PTRN_$C(BSF) D Q:SFL=1
79 . I '$D(^PRCN(413,"B",TTRN)) S SFL=1,SUF=$C(BSF) Q
80 K TTRN,BSF,SFL
81 Q
Note: See TracBrowser for help on using the repository browser.