source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHCS9.m@ 862

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

initial load of WorldVistAEHR
File size: 3.5 KB
Line 
1PRCHCS9 ;WISC/RWS,RHD-BUILD ISMS CODE SHEET DATA ;12/1/93 09:53
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4ADDRS ;GET BILL TO & SHIP TO ADDRESS
5 S PRCH("ST")=$P(^PRC(442,PRCHPO,1),U,3),PRCH("BI")=$P(^(12),U,6)
6 S PRCH("CU")=$G(^PRC(411,PRC("SITE"),3))
7 I PRCH("ST") S PRCH("ST")=$G(^PRC(411,PRC("SITE"),1,PRCH("ST"),0))
8 I PRCH("BI") S PRCH("BI")=$G(^PRC(411,PRC("SITE"),4,PRCH("ST"),0))
9 Q
10PRIORITY S X=$S($P($G(^PRC(442,PRCHPO,1)),U,19)=1:3,$P($G(^(17)),U,9)=8:2,1:1),X=$S(PRCHN("SFC")=1:"TO",1:"SO")_X Q
11SETUP ;SETUP VARIABLES - CALLED FROM INPUT TEMPLATE
12 Q:'$D(PRCHPO)&0 D ADDRS S PRCHI="",PRCHI("PODATE")=$P(^PRC(442,PRCHPO,1),U,15),PRCH0=^(0) Q
13ITEM ;SET UP LINE ITEM VARIABLES
14 Q:PRCFASYS'="ISM"&0 S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)),X=$S(PRCHI:PRCHI,1:"") Q:'PRCHI S PRCHI0=^(PRCHI,0) W "." Q
15 Q
16BLDAR ; BUILD THE PRCHTP ARRAY
17 K PRCHTP D ADDRS S PRCHTP(1)="442,"_PRCHPO_",^PRC(442,",PRCHTP(2)="442.01,PRCHLI,^PRC(442,"_PRCHPO_",2,"
18 S PRCHTP(1,1)="S X=""ISM"";500"
19 S PRCHTP(1,2)="S X=PRC(""SITE"");1"
20 S PRCHTP(1,3)="107;63"
21 S PRCHTP(1,4)="D PRIORITY^PRCHCS9;3"
22 S PRCHTP(1,5)="S X=""T"";501"
23 S PRCHTP(1,6)="S X=""N"";502"
24 S PRCHTP(1,6)="S X=PRCHPONO;503"
25 S PRCHTP(1,8)="S X=1;504"
26 S PRCHTP(1,9)="S X=""|HE"";540"
27 S PRCHTP(1,10)=".1;541"
28 S PRCHTP(1,11)="S X=""01"";542"
29 S PRCHTP(1,12)="7;543"
30 S PRCHTP(1,13)="S X=PRCHLCNT;520"
31 S PRCHTP(1,14)="S X=""|AC"";570"
32 S PRCHTP(1,15)="1.4;78"
33 S PRCHTP(1,16)="S X=PRC(""FY"");80"
34 S PRCHTP(1,17)="2;81"
35 S PRCHTP(1,18)="1;82"
36 S PRCHTP(1,19)="S X=""|CU"";512"
37 S PRCHTP(1,20)="S X=$P(^PRC(411,PRC(""SITE""),0),U,10);512.2"
38 S PRCHTP(1,21)="S X=0;512.1"
39 S PRCHTP(1,22)="S X=$P(PRCH(""CU""),U,1);512.3"
40 S PRCHTP(1,23)="S X=$P(PRCH(""CU""),U,2);512.4"
41 S PRCHTP(1,24)="S X=$P(PRCH(""CU""),U,3);512.7"
42 S PRCHTP(1,25)="S X=$P(PRCH(""CU""),U,4) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);512.8"
43 S PRCHTP(1,26)="S X=$P(PRCH(""CU""),U,5);512.9"
44 S PRCHTP(1,27)="S X=""|BI"";513"
45 S PRCHTP(1,28)="S X=$P(PRCH(""BI""),U,1);513.1"
46 S PRCHTP(1,29)="S X=0;513.2"
47 S PRCHTP(1,30)="S X=$P(PRCH(""BI""),U,2);513.3"
48 S PRCHTP(1,32)="S X=$P(PRCH(""BI""),U,3);513.4"
49 S PRCHTP(1,32)="S X=$P(PRCH(""BI""),U,4);513.5"
50 S PRCHTP(1,33)="S X=$P(PRCH(""BI""),U,5);513.7"
51 S PRCHTP(1,34)="S X=$P(PRCH(""BI""),U,6) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);513.8"
52 S PRCHTP(1,35)="S X=$P(PRCH(""BI""),U,7);513.9"
53 S PRCHTP(1,36)="S X=""|ST"";514"
54 S PRCHTP(1,37)="S X=$P(PRCH(""ST""),U,1);514.2"
55 S PRCHTP(1,38)="S X=0;514.1"
56 S PRCHTP(1,39)="S X=$P(PRCH(""ST""),U,2);514.3"
57 S PRCHTP(1,40)="S X=$P(PRCH(""ST""),U,3);514.4"
58 S PRCHTP(1,41)="S X=$P(PRCH(""ST""),U,4);514.5"
59 S PRCHTP(1,42)="S X=$P(PRCH(""ST""),U,5);514.7"
60 S PRCHTP(1,43)="S X=$P(PRCH(""ST""),U,6) S:X]"""" X=$P($G(^DIC(5,X,0)),U,2);514.8"
61 S PRCHTP(1,44)="S X=$P(PRCH(""ST""),U,7);514.9"
62 S PRCHTP(1,45)="D LINE^PRCHCS9 S X=""|$"";507"
63 QUIT
64LINE ; TRANSFER LINE ITEM DATA OVER
65 N I,J S PRCHI=0 F S PRCHI=$O(^PRC(442,PRCHPO,2,PRCHI)) Q:'PRCHI S X=^(PRCHI,0) W "."_PRCHI D
66 .S PRCHI(0,20)="|IT"
67 .S PRCHI(0,1)=$P(X,U,1)
68 .S PRCHI(0,2)=$P(X,U,13)
69 .S PRCHI(0,4)=$P(X,U,4)
70 .S PRCHI(1,2)=$P(X,U,3)
71 .S PRCHI(0,3)=$P(X,U,16)
72 .S PRCHI(1,5)=$P(X,U,4)
73 .S PRCHI(1,10)="0"
74 .I $D(^PRC(442,PRCHPO,2,PRCHI,4)) N X4 S X4=^(4) D
75 ..S PRCHI(1,6)=$P(X4,U,15)
76 ..S PRCHI(1,7)=$P(X4,U,16)
77 .S $P(^PRCF(423,PRCFA("CSDA"),52,0),U,3,4)=$P(^PRC(442,PRCHPO,2,0),U,3,4)
78 .S I="" F S I=$O(PRCHI(I)) Q:I="" S J="" F S J=$O(PRCHI(I,J)) Q:J="" D
79 ..S $P(^PRCF(423,PRCFA("CSDA"),52,PRCHI,I),U,J)=PRCHI(I,J)
80 S PRCHLI="QUIT" QUIT
Note: See TracBrowser for help on using the repository browser.