source: WorldVistAEHR/trunk/r/PATIENT_DATA_EXCHANGE-VAQ/VAQPST04.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.4 KB
Line 
1VAQPST04 ;ALB/JFP - PDX, POST INIT ROUTINE ;01JUN93
2 ;;1.5;PATIENT DATA EXCHANGE;;NOV 17, 1993
3ALL ; --Creates an entry in the Segment Group file 394.84 of all segments
4 I '$D(^VAT(394.71)) QUIT
5 ;IF IT'S ALREADY THERE, DELETE IT
6 S DA=""
7 F S DA=+$O(^VAT(394.84,"B","ALL",DA)) Q:('DA) D
8 .Q:($P(^VAT(394.84,DA,0),"^",2)=0)
9 .S DIK="^VAT(394.84,"
10 .D ^DIK K DIK
11 W !," Creating a segment group called ""ALL"" "
12 W !," This group will contain all data segments"
13 S DIC="^VAT(394.84,",DIC(0)="L",DLAYGO=394.84,X="ALL"
14 S DIC("DR")=".02///PUBLIC" ; -- Public
15 K DD,DO
16 D FILE^DICN K DIC,DLAYGO,X,DINUM
17 I Y=-1 QUIT
18 ; -- Add segments
19 S DA=$P(Y,U,1),DIE="^VAT(394.84,",SEG=""
20 F S SEG=$O(^VAT(394.71,"B",SEG)) Q:SEG="" D S1
21 W !,"Done"
22 K SEG,DA,DIE
23 QUIT
24S1 ; -- Update existing entry
25 W !," ",SEG," - added"
26 S DR="10///"_SEG
27 S DR(2,394.841)=".01///"_SEG
28 D ^DIE K DR
29 QUIT
30 ;
31 ;
32COP ; -- Creates entries in Segment group file from Health Summary Type file^GMT(142,
33 N TMP
34 I '$D(^GMT(142)) QUIT
35 S DIR(0)="Y",DIR("B")="NO"
36 S DIR("A")="Create entries in Segment Groups from Health Summary Type File"
37 D ^DIR K DIR
38 I ('Y)!($D(DUOUT))!($D(DTOUT)) QUIT
39 ;
40 S GRP=""
41 F S GRP=$O(^GMT(142,"B",GRP)) Q:GRP="" D G1
42 QUIT
43 ;
44G1 ;
45 ;IF IT'S ALREADY THERE, DELETE IT
46 S DA=""
47 F S DA=+$O(^VAT(394.84,"B",GRP,DA)) Q:('DA) D
48 .Q:($P(^VAT(394.84,DA,0),"^",2)=0)
49 .S DIK="^VAT(394.84,"
50 .D ^DIK K DIK
51 Q:(GRP="GMTS HS ADHOC OPTION")
52 S ENTRY="",ENTRY=$O(^GMT(142,"B",GRP,ENTRY))
53 S DIC="^VAT(394.84,",DIC(0)="L",DLAYGO=394.84,X=GRP
54 S DIC("DR")=".02///PUBLIC" ; -- Public
55 K DD,DO
56 D FILE^DICN K DIC,DLAYGO,X,DINUM
57 I Y=-1 QUIT
58 ; -- Set components within entry
59 W !!,?3,GRP," <-- Segment group added, the list of components follows"
60 S DA=$P(Y,U,1),DIE="^VAT(394.84,",SEGPT=""
61 F S SEGPT=$O(^GMT(142,ENTRY,1,"C",SEGPT)) Q:SEGPT="" D S0
62 K SEG,DA,DIE
63 QUIT
64 ;
65S0 ;
66 S SEG=$P($G(^GMT(142.1,SEGPT,0)),U,4)
67 S SEGNM=$P($G(^GMT(142.1,SEGPT,0)),U,1)
68 ;FILTER OUT NON-SUPPORTED COMPONENTS
69 I ((SEG'="")&($D(^VAT(394.71,"C",SEG)))) D S2
70 QUIT
71 ;
72S2 ; -- Update existing entry
73 W !,?10,SEG
74 S DR="10///"_SEG
75 S DR(2,394.841)=".01///"_SEG
76 ;DETERMINE IF TIME & OCCURRENCE LIMITS ARE APPLICABLE
77 S TMP=$$LIMITS^VAQDBIH3(SEGPT)
78 ;PUT TIME LIMIT OF 1 YEAR (IF APPLICABLE)
79 S:($P(TMP,"^",1)) DR(2,394.841)=DR(2,394.841)_";.04///1Y"
80 ;PUT OCCURRENCE LIMIT OF 10 (IF APPLICABLE)
81 S:($P(TMP,"^",2)) DR(2,394.841)=DR(2,394.841)_";.05///10"
82 D ^DIE K DR
83 W ?16," - ",SEGNM
84 QUIT
85 ;
86END ; -- End of code
87 QUIT
Note: See TracBrowser for help on using the repository browser.