source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCPOS04A.m@ 1667

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

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1MCPOS04A ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96 08:35
2 ;;2.3;Medicine;;09/13/1996
3 ;
4 ; WORD PROCESSING FIELDS
5 S %X="^MCAR(699,"_MC699D0_",20,",%Y="^MCAR(699.5,"_MC6995D0_",20,"
6 D %XY^%RCR ; SUBJECTIVE WP
7 S %X="^MCAR(699,"_MC699D0_",21,",%Y="^MCAR(699.5,"_MC6995D0_",21,"
8 D %XY^%RCR ; OBJECTIVE WP
9 S %X="^MCAR(699,"_MC699D0_",22,",%Y="^MCAR(699.5,"_MC6995D0_",22,"
10 D %XY^%RCR ; ASSESSMENT WP
11 S %X="^MCAR(699,"_MC699D0_",23,",%Y="^MCAR(699.5,"_MC6995D0_",35,"
12 D %XY^%RCR ; PLANNED WP
13 ;
14 ; MEDICATIONS
15 S MC699D1=0
16 F S MC699D1=$O(^MCAR(699,MC699D0,8,MC699D1)) Q:MC699D1'>0 D
17 . S MCDATA=+$P($G(^MCAR(699,MC699D0,8,MC699D1,0)),U)
18 . I $O(^MCAR(699.5,MC6995D0,4,"B",MCDATA,0)) Q
19 . I $P($G(^PSDRUG(MCDATA,0)),U)="" Q
20 . K DD,DIC,DINUM,DO
21 . S DIC="^MCAR(699.5,"_MC6995D0_",4,",DIC(0)="L"
22 . S DIC("P")=$$GET1^DID(699.5,5,"","SPECIFIER"),DLAYGO=699.5
23 . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
24 . Q
25 ;
26 ; TECHNIQUE
27 S MC699D1=0
28 F S MC699D1=$O(^MCAR(699,MC699D0,2,MC699D1)) Q:MC699D1'>0 D
29 . S MCDATA=+$P($G(^MCAR(699,MC699D0,2,MC699D1,0)),U)
30 . I $O(^MCAR(699.5,MC6995D0,2,"B",MCDATA,0)) Q
31 . I $P($G(^MCAR(699.6,MCDATA,0)),U)="" Q
32 . K DD,DIC,DINUM,DO
33 . S DIC="^MCAR(699.5,"_MC6995D0_",2,",DIC(0)="L"
34 . S DIC("P")=$$GET1^DID(699.5,7,"","SPECIFIER"),DLAYGO=699.5
35 . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
36 . Q
37 ;
38 ; COMPLICATIONS
39 S MC699D1=0
40 F S MC699D1=$O(^MCAR(699,MC699D0,17,MC699D1)) Q:MC699D1'>0 D
41 . S MCDATA=+$P($G(^MCAR(699,MC699D0,17,MC699D1,0)),U)
42 . I $O(^MCAR(699.5,MC6995D0,3,"B",MCDATA,0)) Q
43 . I $P($G(^MCAR(696.9,MCDATA,0)),U)="" Q
44 . K DD,DIC,DINUM,DO
45 . S DIC="^MCAR(699.5,"_MC6995D0_",3,",DIC(0)="L"
46 . S DIC("P")=$$GET1^DID(699.5,3,"","SPECIFIER"),DLAYGO=699.5
47 . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
48 . Q
49 ;
50 ; ICD DIAGNOSIS
51 S MC699D1=0
52 F S MC699D1=$O(^MCAR(699,MC699D0,"ICD",MC699D1)) Q:MC699D1'>0 D
53 . S MCDATA=$G(^MCAR(699,MC699D0,"ICD",MC699D1,0))
54 . S MCNARRDX=$P(MCDATA,U,2)
55 . I $O(^MCAR(699.5,MC6995D0,"ICD","B",+$P(MCDATA,U),0)) Q
56 . I $P($G(^ICD9(+$P(MCDATA,U),0)),U)="" Q
57 . K DD,DIC,DINUM,DO
58 . S DIC="^MCAR(699.5,"_MC6995D0_",""ICD"",",DIC(0)="L"
59 . S DIC("P")=$$GET1^DID(699.5,700,"","SPECIFIER"),DLAYGO=699.5
60 . I MCNARRDX]"" S DIC("DR")=".02///^S X=$E(MCNARRDX,1,80)"
61 . S (D0,DA(1))=MC6995D0,X=+$P(MCDATA,U) D FILE^DICN K MCNARRDX
62 . Q
63 ;
64 ; IMAGE
65 S MC699D1=0
66 F S MC699D1=$O(^MCAR(699,MC699D0,2005,MC699D1)) Q:MC699D1'>0 D
67 . S MCDATA=+$P($G(^MCAR(699,MC699D0,2005,MC699D1,0)),U)
68 . I $O(^MCAR(699.5,MC6995D0,2005,"B",MCDATA,0)) Q
69 . I $P($G(^MAG(2005,MCDATA,0)),U)="" Q
70 . K DD,DIC,DINUM,DO
71 . S DIC="^MCAR(699.5,"_MC6995D0_",2005,",DIC(0)="L"
72 . S DIC("P")=$$GET1^DID(699.5,2005,"","SPECIFIER"),DLAYGO=699.5
73 . S (D0,DA(1))=MC6995D0,X=MCDATA D FILE^DICN
74 . Q
75 Q
Note: See TracBrowser for help on using the repository browser.