source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH7A.m@ 1800

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1PRCH7A ;WISC/PLT-Receiver documents - ORA from ORACLE ; 07/01/98 3:37 PM
2V ;;5.1;IFCAP;**20**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6 ;invoked from task manager (see trin^prcosrv2)
7 ;convert message to file 440.6
8 ;PRCDA=ri of file 423.6 passed
9CCR ;Conversion CCR message from FMS MESSAGE SEVER routine PRCOSRV2
10 N PRCRI,PRCEDIT,PRCTY,PRCERR,PRCSEQ,PRCEX,A,B
11 S PRCRI(423.6)=PRCDA,PRCTY=""
12 ;copy ORACLE records to file 440.6
13 D ICLOCK^PRC0B("^PRCH(440.8,")
14 D COPY(PRCRI(423.6))
15 D DCLOCK^PRC0B("^PRCH(440.8,")
16 ;
17EXIT ;delete ORACLE message in file 423.6
18 D KILL^PRCOSRV3(PRCRI(423.6))
19 QUIT
20 ;
21 ;
22COPY(PRCA) ;PRCA=ri of file 423.6
23 N PRCRI,PRCC,PRCD,PRCE,PRCT,PRCDUZ,PRCTTC,PRCDO,PRCEX,PRCSYS
24 N A,B,PRCX,X,Y
25 S PRCSYS=1
26 S X="NEW",X("DR")="1///NOW;6///T" D ADD^PRC0B1(.X,.Y,"440.8;^PRCH(440.8,") QUIT:Y<1
27 S PRCRI(440.8)=+Y
28 S PRCC=$O(^PRCF(423.6,PRCA,1,9999)),PRCTTC=0
29 D EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"2///NOW")
30 F S PRCC=$O(^PRCF(423.6,PRCA,1,PRCC)) Q:'PRCC S PRCD=^(PRCC,0) D:PRCD["~"
31 . S PRCT=$P(PRCD,"^")
32 . S PRCX=$P(PRCD,"^",22)
33 . D:PRCT="CCT"
34 .. D EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),".01////"_$P(PRCD,"^",3)_";4////"_$P(PRCD,"^",2))
35 .. QUIT
36 . D:PRCT="CCR"
37 .. S PRCTTC=PRCTTC+1,PRCE="C"_$P(PRCD,"^",2)_$P(PRCD,"^",4),PRCRI(440.6)=$O(^PRCH(440.6,"B",PRCE,""))
38 .. I PRCRI(440.6) QUIT:$P(^PRCH(440.6,PRCRI(440.6),0),"^",16)'="N"&($P(^(0),"^",16)]"")
39 .. I 'PRCRI(440.6) S X=PRCE D ADD^PRC0B1(.X,.Y,"440.6;^PRCH(440.6,") QUIT:Y<1 S PRCRI(440.6)=+Y
40 .. S PRCDUZ="" I $P(PRCD,"^",5)]"" S PRCRI(440.5)=$O(^PRC(440.5,"B",$P(PRCD,"^",5),"")) I PRCRI(440.5) S PRCDUZ=$P(^PRC(440.5,PRCRI(440.5),0),"^",8)
41 .. S X="1////"_$P(PRCD,"^",3)_";2////"_$P(PRCD,"^",4)_";3////"_$P(PRCD,"^",5)_";4////"_$P(PRCD,"^",6)_";7////"_$P(PRCD,"^",9)_";9////"_$P(PRCD,"^",11)_";12////"_$P(PRCD,"^",14)_";13////"_$P(PRCD,"^",15)_";14////"_$P(PRCD,"^",21)
42 .. S X(1,440.6,1)="20////^S X=PRCX"_";21////"_$P(PRCD,"^",16)_";22////"_$P(PRCD,"^",17)_";23////"_$P(PRCD,"^",18)_";24////"_$P(PRCD,"^",19)_";25////"_$P(PRCD,"^",20)_";16////"_PRCDUZ
43 .. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),"")
44 .. ;edit date fields and status
45 .. F A=7,10 S B=$P(PRCD,"^",A),$P(PRCD,"^",A)=$E(B,3,4)_"/"_$E(B,5,6)_"/"_$E(B,1,2)
46 .. S B=$P(PRCD,"^",8),$P(PRCD,"^",8)=$E(B,1,2)_"/"_$E(B,3,4)_"/"_$E(B,5,6)
47 .. S:$P(PRCD,"^",13)="" $P(PRCD,"^",13)=$P(PRCD,"^",12)
48 .. S A="15////N;8///"_$P(PRCD,"^",10)_";6///"_$P(PRCD,"^",8)_";5///"_$P(PRCD,"^",7)_";10///"_$P(PRCD,"^",12)_";11///"_$P(PRCD,"^",13)
49 .. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)
50 .. QUIT
51 . D:PRCT="CC1"&$G(PRCRI(440.6))
52 .. ;I $P(PRCD,"^",9)]"",$P(PRCD,"^",11)]"" QUIT:$TR($P(PRCD,"^",9,11),"^")'=$E(PRCE,2,999)
53 .. S A="31////"_$P(PRCD,"^",2)_";32////"_$P(PRCD,"^",3)_";33////"_$P(PRCD,"^",4)_";34////"_$P(PRCD,"^",5)_";35////"_$P(PRCD,"^",6)_";36////"_$TR($P(PRCD,"^",7,8),"^","")
54 .. D EDIT^PRC0B(.X,"440.6;^PRCH(440.6,;"_PRCRI(440.6),A)
55 .. S PRCRI(440.6)=""
56 .. QUIT
57 . ;new purchase card data from AFS
58 . D:PRCT="CCD"
59 .. S PRCTTC=PRCTTC+1,PRCEDIT=0,PRCE=$P(PRCD,"^",2),PRCRI(440.5)=$O(^PRC(440.5,"B",PRCE,""))
60 .. S:PRCRI(440.5) PRCEDIT=1
61 .. I 'PRCRI(440.5) S X=PRCE D ADD^PRC0B1(.X,.Y,"440.5;^PRC(440.5,") QUIT:Y<1 S PRCRI(440.5)=+Y
62 .. S PRCE="51////"_$P(PRCD,"^",3)_$$CCNR^PRCH0A($P(PRCD,"^",3)),$P(PRCE,";",2)="52////"_$P(PRCD,"^",6)
63 .. S $P(PRCE,";",3)="53////"_$P(PRCD,"^",7)_$$ST^PRCH0A($P(PRCD,"^",7))_$$STR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",7))
64 .. S $P(PRCE,";",4)="54////"_$P(PRCD,"^",4)
65 .. S $P(PRCE,";",5)="55////"_$P(PRCD,"^",9)_$$FC^PRCH0A($P(PRCD,"^",9))_$$FCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",9))
66 .. S $P(PRCE,";",6)="56////"_$P(PRCD,"^",10)_$$ACC^PRCH0A($P(PRCD,"^",10))_$$ACCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",10))
67 .. S $P(PRCE,";",7)="57////"_$P(PRCD,"^",11)_$$CC^PRCH0A($P(PRCD,"^",11))_$$CCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",11))
68 .. S $P(PRCE(1,440.5,1),";",1)="58////"_$P(PRCD,"^",12)_$$BOC^PRCH0A($P(PRCD,"^",12),$P(PRCD,"^",11))_$$BOCR^PRCH0A($P(PRCD,"^",3),$P(PRCD,"^",12))
69 .. S B=$P(PRCD,"^",5),B=$E(B,5,6)_"/"_$E(B,7,8)_"/"_$E(B,1,4)
70 .. S A=$$FFVV^PRCH0A(440.5,16,B),B="" S:'$P(PRCD,"^",5)!'A B="*"
71 .. S $P(PRCE(1,440.5,1),";",2)="59////"_$P(PRCD,"^",5)_B
72 .. S $P(PRCE(1,440.5,1),";",3)="60////"_$P(PRCD,"^",2)_$$CCN^PRCH0A($P(PRCD,"^",2))
73 .. S A=$$FFVV^PRCH0A(440.5,4,$P(PRCD,"^",14)),B="" S:$P(PRCD,"^",14)>$P(PRCD,"^",15)!'A!'$P(PRCD,"^",14) B="*" S $P(PRCE(1,440.5,1),";",4)="61////"_$P(PRCD,"^",14)_B
74 .. S A=$$FFVV^PRCH0A(440.5,5,$P(PRCD,"^",15)),B="" S:$P(PRCD,"^",15)<$P(PRCD,"^",14)!'A!'$P(PRCD,"^",15) B="*" S $P(PRCE(1,440.5,1),";",5)="62////"_$P(PRCD,"^",15)_B
75 ..D EDIT^PRC0B(.PRCE,"440.5;^PRC(440.5,;"_PRCRI(440.5),"") K PRCE
76 .. I $P(PRCD,"^",3)]"" S $P(PRCD,"^",3)=$O(^PRC(440.5,"B",$P(PRCD,"^",3),0))
77 .. S PRCDO="" I $P(PRCD,"^",3) S PRCDO=$G(^PRC(440.5,$P(PRCD,"^",3),0)) S A="6////"_$P(PRCDO,"^",7)_";7////"_$P(PRCDO,"^",8)_";8////"_$P(PRCDO,"^",9)_";9////"_$P(PRCDO,"^",10)_";10////"_$P(PRCDO,"^",11) D
78 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),A)
79 ... QUIT
80 .. I $P(PRCD,"^",3) S PRCRI=$P(PRCD,"^",3),PRCRI(440.512)=0 F S PRCRI(440.512)=$O(^PRC(440.5,PRCRI,1,PRCRI(440.512))) QUIT:PRCRI(440.512)<1 S B=$G(^(PRCRI(440.512),0)) D
81 ... S X=$P(B,"^") I X,'$D(^PRC(440.5,PRCRI(440.5),1,+X)) D ADD^PRC0B1(.X,.Y,"440.5;^PRC(440.5,;"_PRCRI(440.5)_";12~440.512;^PRC(440.5,"_PRCRI(440.5)_",1,",+X)
82 ... QUIT
83 .. S A=$G(^PRC(440.5,PRCRI(440.5),0)),B=$G(^(50)),C=$G(^(2)),D=1,PRCE=""
84 .. S D=1 I $P(A,"^",8)]"",$P(PRCD,"^",7)]"",$P(PRCDO,"^",2)]"" S $P(PRCE,";",D)="63////"_$P($P(PRCDO,"^",2)," ")_$$UFCP^PRCH0A($P(A,"^",8),$P(PRCD,"^",7),$P(PRCDO,"^",2)),D=D+1
85 .. D:PRCE]"" EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),PRCE)
86 .. S PRCEX="",A=$G(^PRC(440.5,PRCRI(440.5),50)) S:A["*" PRCEX=PRCEX_"*" S:A["#" PRCEX=PRCEX_"#"
87 .. D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"14////"_$S(PRCEX["*":"Y",1:"N")_";70////"_$S(PRCEX]"":"E",1:"P")_";71////"_DT)
88 .. I PRCEX'["*" D
89 ... S PRCE=$G(^PRC(440.5,PRCRI(440.5),50))
90 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"4////"_$P(PRCE,"^",11))
91 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"5////"_$P(PRCE,"^",12))
92 ... S B=$P(PRCE,"^",9) D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"16///"_$E(B,5,6)_"/"_$E(B,7,8)_"/"_$E(B,1,4))
93 ... D EDIT^PRC0B(.X,"440.5;^PRC(440.5,;"_PRCRI(440.5),"2////"_$P(PRCD,"^",11)_";3////"_$P(PRCD,"^",12)_";15////"_$P(PRCD,"^",7)_";1////"_$P(PRCDO,"^",2))
94 ... QUIT
95 .. QUIT
96 . QUIT
97 D EDIT^PRC0B(.X,"440.8;^PRCH(440.8,;"_PRCRI(440.8),"3///NOW;5////"_PRCTTC)
98 QUIT
Note: See TracBrowser for help on using the repository browser.