source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRC5B3.m@ 1688

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

initial load of FOIAVistA 6/30/08 version
File size: 2.9 KB
Line 
1PRC5B3 ;WISC/PLT-PRC5B continue ; 10/14/94 9:47 AM
2V ;;5.0;IFCAP;;4/21/95
3 QUIT ;invalid entry
4 ;
5PAC ;set-up fcp/prj dic (called by prc5b)
6 N PRCRI,PRCA,PRCB,PRCC,PRCSTRI
7 D EN^DDIOL("POST INITIAL: Process FMS PAC-DOCUMENT"_" at "_$$NOW^PRC5A)
8 S PRCSTRI=$O(^PRCD(420.1999,"AC","A",""))
9 S PRCRI(420.92)=0 F S PRCRI(420.92)=$O(^PRCU(420.92,"B","PAC",PRCRI(420.92))) Q:'PRCRI(420.92) S PRCA=^PRCU(420.92,PRCRI(420.92),0) D:$P(PRCA,"^",4)]""&($P(PRCA,"^",6)="")
10 . D ED^PRC5B1(PRCRI(420.92),1)
11 . S PRCRI(420.923)=0
12 . F S PRCRI(420.923)=$O(^PRCU(420.92,PRCRI(420.92),1,PRCRI(420.923))) Q:'PRCRI(420.923) D:$P(^(PRCRI(420.923),0),"^",2)="" PACED(PRCRI(420.92),PRCRI(420.923))
13 . D ED^PRC5B1(PRCRI(420.92),2)
14 D EN^DDIOL("POST INITIAL: Process FMS PAC-DOCUMENT done!"_" at "_$$NOW^PRC5A)
15 QUIT
16 ;
17PACED(PRCA,PRCB) ;set-up fcp/prj dic (station related)
18 N PRCRI,PRCSITE,PRCACC,PRCACCD,A
19 S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCSITE=$P(A,"~",3),PRCACC=$P(A,"~",4),PRCACCD=$P(A,"~",5)
20 Q:PRCSITE=""!(PRCACC="")
21 Q:'$D(^PRC(411,+PRCSITE))
22 S PRCRI(420.131)=$O(^PRCD(420.131,"B",PRCACC,""))
23 I PRCRI(420.131)="" D QUIT:PRCRI(420.131)<1
24 . N X,Y
25 . S X=PRCACC,X("DR")="1////"_PRCACCD_";2////"_PRCSTRI
26 . D ADD^PRC0B1(.X,.Y,"420.131;^PRCD(420.131,")
27 . S:Y PRCRI(420.131)=+Y
28 . QUIT
29 D ED1^PRC5B1(PRCA,PRCB) ;edit convert field
30 QUIT
31 ;
32 ;
33CC ;deactivate the cost cent 6-digit codes without ending '00'
34 N PRCRI,PRCA
35 D EN^DDIOL("POST INITIAL: DEACTIVATE SUBCOSTCENT STARTS at "_$$NOW^PRC5A)
36 S PRCRI(420.1)=0 F S PRCRI(420.1)=$O(^PRCD(420.1,PRCRI(420.1))) Q:'PRCRI(420.1) S A=^(PRCRI(420.1),0) D
37 . S PRCA=$P(A," ") QUIT:$E(PRCA,5,6)<1
38 . D EDIT^PRC0B(.X,"420.1;;"_PRCRI(420.1),".5////1")
39 . QUIT
40 D EN^DDIOL("POST INITIAL: DEACTIVATE SUBCOSTCENT ENDS at "_$$NOW^PRC5A)
41 QUIT
42 ;
43SUB ;add entry to file 420.137 (called from prc5b)
44 N PRCRI,PRCA,PRCB,PRCC,PRCSTRI
45 D EN^DDIOL("POST INITIAL: Process FMS SUB-DOCUMENT at "_$$NOW^PRC5A)
46 S PRCSTRI=$O(^PRCD(420.1999,"AC","A",""))
47 S PRCRI(420.92)=0 F S PRCRI(420.92)=$O(^PRCU(420.92,"B","SUB",PRCRI(420.92))) Q:'PRCRI(420.92) S PRCA=^PRCU(420.92,PRCRI(420.92),0) D:$P(PRCA,"^",4)]""&($P(PRCA,"^",6)="")
48 . D ED^PRC5B1(PRCRI(420.92),1)
49 . S PRCRI(420.923)=0
50 . F S PRCRI(420.923)=$O(^PRCU(420.92,PRCRI(420.92),1,PRCRI(420.923))) Q:'PRCRI(420.923) D:$P(^(PRCRI(420.923),0),"^",2)="" SUBED(PRCRI(420.92),PRCRI(420.923))
51 . D ED^PRC5B1(PRCRI(420.92),2)
52 D EN^DDIOL("POST INITIAL: Process FMS SUB-DOCUMENT done!"_" at "_$$NOW^PRC5A)
53 QUIT
54 ;
55SUBED(PRCA,PRCB) ;set -up sub-obj dic
56 N PRCRI,PRCSUB,PRCSUBD,A
57 S A=^PRCU(420.92,PRCA,1,PRCB,1),PRCSUB=$P(A,"~",3)_$P(A,"~",4),PRCSUBD=$P(A,"~",5)
58 QUIT:PRCSUB=""
59 S PRCRI(420.137)=$O(^PRCD(420.137,"B",PRCSUB,""))
60 I PRCRI(420.137)="" D QUIT:PRCRI(420.137)<1
61 . N X,Y
62 . S X=PRCSUB,X("DR")="1////"_PRCSUBD_";2////"_PRCSTRI
63 . D ADD^PRC0B1(.X,.Y,"420.137;^PRCD(420.137,")
64 . S:Y PRCRI(420.137)=+Y
65 . QUIT
66 D ED1^PRC5B1(PRCA,PRCB) ;edit convert field
67 QUIT
68 ;
Note: See TracBrowser for help on using the repository browser.