close Warning: Can't use blame annotator: 
svn blame failed on WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSF2.m: 'GenericSWIGWrapper' object has no attribute '_wrap'

source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSF2.m@ 1769

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

initial load of WorldVistAEHR
File size: 3.9 KB
RevLine 
1PRCHSF2 ;WISC/DJM-UPDATES OR PLACES BOCS & AMOUNTS INTO PO FILE AFTER AMENDMENT ;2/23/95 1:12 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;CONTINUATION OF 'PRCHSF1'
5DUPS ;CREAT ARRAY TO PREVENT DUPLICATES FROM BOC MULTIPLE IN CHANGES
6 ;MULTIPLE.
7 S C1=0 K ^TMP($J)
8 F S C1=$O(^PRC(442,PRCHPO,6,PRCHAM,3,C1)) Q:C1'>0 D
9 .S C2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,C1,0)) Q:C2=""
10 .S RECORD=$P(C2,U,4)
11 .S FF=$P(C2,U,3)
12 .S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,C1)=""
13 .Q
14CHANGES ;ANY DIFFERENCES IN THE BOC MULTIPLE NEED TO BE ADDED INTO 'CHANGES'
15 S BOC=0 S:$D(DA(1)) PRCHDA1=DA(1) S PRCHDA=DA
16 F S BOC=$O(^PRC(442,PRCHPO,22,BOC)) Q:BOC'>0 S OBOC=0 D
17 .S BOC1=$G(^PRC(442,PRCHPO,22,BOC,0))
18 .S DA(2)=PRCHPO,DA(1)=PRCHAM,LINO=$P(BOC1,U,3)
19C0 .I LINO=991 S OBOC=$G(^PRC(443.6,PRCHPO,22,BOC,0))
20 .I LINO'=991 S OBOC=$O(^PRC(443.6,PRCHPO,22,"B",+$P(BOC1,U),OBOC))
21 .I OBOC=""!(LINO=991) D Q
22 ..S RECORD=BOC
23 ..S FF=".01;442.041:41"
24 ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) G:C1>0 CX
25 ..S OLD=$S(LINO=991:$P(OBOC,U),1:0)
26 ..I LINO=991,OLD=$P(BOC1,U) G CX
27 ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
28C1 ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C1
29 ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y,DIE=DIC
30 ..S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
31 ..D ^DIE
32 ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
33CX ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
34 ..S FF="1;442.041:41"
35 ..S RECORD=BOC
36 ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) G:C1>0 CY
37 ..S OLD=$S(LINO=991:$P(OBOC,U,2),1:0)
38 ..I LINO=991,OLD=$P(BOC1,U,2) G CY
39C1A ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C1A
40 ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y,DIE=DIC
41 ..S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
42 ..D ^DIE
43 ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
44CY ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
45 ..Q:LINO=991
46 ..S RECORD=BOC
47 ..S FF="2;442.041:41"
48 ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) Q:C1>0
49C1B ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C1B
50 ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y
51 ..S OLD=0,DIE=DIC
52 ..S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
53 ..D ^DIE
54 ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
55 ..Q
56CZ .S OBOC1=$G(^PRC(443.6,PRCHPO,22,OBOC,0)),OLINO=$P(OBOC1,U,3) G:OLINO'=LINO C0
57 .S OLD=$P(OBOC1,U,2),FF="1;442.041:41",RECORD=BOC Q:OLD=$P(BOC1,U,2)
58 .S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) Q:C1>0
59 .S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
60C2 .S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C2
61 .K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y,DIE=DIC
62 .S DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
63 .D ^DIE
64 .S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
65 .Q
66 ;LOOP THROUGH AGAIN, CHECKING FOR BOC AMOUNT = 0
67 S BOC=0 F S BOC=$O(^PRC(442,PRCHPO,22,BOC)) Q:BOC'>0 D
68 .S BOC1=$G(^PRC(442,PRCHPO,22,BOC,0)),AMNT=$P(BOC1,U,2),FMSNO=$P(BOC1,U,3)
69 .I AMNT=0 D
70 ..S OBOC=$O(^PRC(443.6,PRCHPO,22,"B",+$P(BOC1,U),0)) Q:OBOC'>0
71 ..S OBOC1=$G(^PRC(443.6,PRCHPO,22,OBOC,0))
72 ..S OLD=$P(OBOC1,U,2),FF="1;442.041:41",RECORD=BOC
73 ..Q:OLD=AMNT
74 ..S C1=$O(^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,0)) Q:C1>0
75 ..S NEXT=$G(^PRC(442,PRCHPO,6,PRCHAM,3,0)),NEXT=$P(NEXT,U,3)
76C3 ..S NEXT=NEXT+1,TEST=$G(^PRC(442,PRCHPO,6,PRCHAM,3,NEXT,0)) G:TEST]"" C3
77 ..K DD,DO,DR S X=NEXT,DIC="^PRC(442,"_DA(2)_",6,"_DA(1)_",3,",DIC(0)="L" D FILE^DICN Q:+Y'>0 S DA=+Y
78 ..S DIE=DIC,DR="2////^S X=FF;3///^S X=OLD;4///^S X=RECORD"
79 ..D ^DIE
80 ..S ^TMP($J,"SF1",PRCHPO,PRCHAM,FF,RECORD,DA)=""
81 ..Q
82 .Q
83 ;
84Q L -^PRC(442,PRCHPO) K PRCHS,I,J,CNT,CTR,M,PTM
85 K ^TMP($J)
86 S:$D(PRCHDA1) DA(1)=PRCHDA1 S DA=PRCHDA K PRCHDA1,PRCHDA
87 Q
Note: See TracBrowser for help on using the repository browser.