source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCPOS04.m@ 1259

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

initial load of WorldVistAEHR

File size: 3.9 KB
Line 
1MCPOS04 ;HIRMFO/DAD-CONSULT CONVERSION 699 >>>===> 699.5 ;7/5/96 10:33
2 ;;2.3;Medicine;;09/13/1996
3 ;
4 S MCONSULT=+$O(^MCAR(697.2,"B","CONSULT",0))
5 S MCFOUND=$S($P($G(^MCAR(697.2,MCONSULT,0)),U)'="CONSULT":0,1:1)
6 ;
7 I $D(XPDNM) D G:'MCFOUND EXIT
8 . K MCDATA
9 . S MCDATA(1)=""
10 . S MCDATA(2)="Moving the Consult data from the Endoscopy/Consult"
11 . S MCDATA(3)="file (#699) to the Generalized Procedure/Consult"
12 . S MCDATA(4)="file (#699.5)."
13 . ;
14 . I 'MCFOUND D
15 .. S MCDATA(5)=""
16 .. S MCDATA(6)="The CONSULT entry was not found in the"
17 .. S MCDATA(7)="PROCEDURE/SPECIALTY file (#697.2), data cannot"
18 .. S MCDATA(8)="be converted without this entry being present."
19 .. Q
20 . D MES^XPDUTL(.MCDATA) K MCDATA
21 . Q
22 E D G EXIT
23 . W !!,"Moving the Consult data from the Endoscopy/Consult"
24 . W !,"file (#699) to the Generalized Procedure/Consult"
25 . W !,"file (#699.5)."
26 . ;
27 . I 'MCFOUND D Q
28 .. W !!,"The CONSULT entry was not found in the"
29 .. W !,"PROCEDURE/SPECIALTY file (#697.2), data cannot"
30 .. W !,"be converted without this entry being present."
31 .. Q
32 . ;
33 . S ZTRTN="TASK^MCPOS04"
34 . S ZTDESC="Medicine Consult Conversion"
35 . S ZTSAVE("MCONSULT")=""
36 . S ZTIO=""
37 . W ! D ^%ZTLOAD
38 . W !!,"Conversion",$S($G(ZTSK)'>0:" not ",1:" "),"queued."
39 . I $G(ZTSK)>0 W !,"Task # ",ZTSK,"."
40 . Q
41TASK ;
42 S MC699D0=0
43 F S MC699D0=$O(^MCAR(699,"D",MCONSULT,MC699D0)) Q:MC699D0'>0 D MAIN
44EXIT ;
45 I '$D(XPDNM),$D(ZTQUEUED) S ZTREQ="@"
46 Q
47MAIN ;
48 K MCDATA
49 F MCNODE=0,.2,15,"PCC","OR","ES","PROV" D
50 . S MCDATA(MCNODE)=$G(^MCAR(699,MC699D0,MCNODE))
51 . Q
52 I $P(MCDATA(0),U,12)'=MCONSULT Q
53 S MCDATE=$P(MCDATA(0),U),MCDFN=$P(MCDATA(0),U,2)
54 S MCPRC=$P(MCDATA(0),U,12)
55 S (MC6995D0,MCIEN)=0
56 F S MCIEN=$O(^MCAR(699.5,"B",MCDATE,MCIEN)) Q:MCIEN'>0!MC6995D0 D
57 . S MC=$G(^MCAR(699.5,MCIEN,0))
58 . S MCNEWDFN=$P(MC,U,2),MCNEWPRC=$P(MC,U,6)
59 . I MCNEWDFN=MCDFN,MCNEWPRC=MCPRC S MC6995D0=MCIEN
60 . Q
61 I MC6995D0'>0 D
62 . K DD,DIC,DINUM,DO
63 . S DIC="^MCAR(699.5,",DIC(0)="L",DLAYGO=699.5
64 . S DIC("DR")=".02///`"_MCDFN_";.05////"_MCPRC
65 . S X=MCDATE D FILE^DICN S MC6995D0=+Y
66 . Q
67 ;
68 I MC6995D0'>0 Q
69 S MCINDCOM=$P(MCDATA(0),U,6),MCSUMMRY=$P(MCDATA(.2),U)
70 S MCPRCSUM=$P(MCDATA(.2),U,2),MCCONTYP=$P(MCDATA(15),U,11)
71 S MCPROVID=$P(MCDATA(0),U,8)
72 I MCPROVID'>0 S MCPROVID=$P(MCDATA("PROV"),U)
73 K DA,DIC,DIE,DR S MCDRNUM=1
74 S DR="2///1"
75 I MCINDCOM]"" S DR(1,699.5,MCDRNUM)="3///^S X=$E(MCINDCOM,1,110)",MCDRNUM=MCDRNUM+1
76 I $P($G(^VA(200,+MCPROVID,0)),U)]"",$D(^XUSEC("PROVIDER",+MCPROVID))#2 S DR(1,699.5,MCDRNUM)="6///`"_MCPROVID,MCDRNUM=MCDRNUM+1
77 I "^A^N^I^"[(U_MCSUMMRY_U) S DR(1,699.5,MCDRNUM)="601///"_MCSUMMRY,MCDRNUM=MCDRNUM+1
78 I MCPRCSUM]"" S DR(1,699.5,MCDRNUM)="600///^S X=$E(MCPRCSUM,1,79)",MCDRNUM=MCDRNUM+1
79 I $P($G(^MCAR(699.82,+MCCONTYP,0)),U)]"" S DR(1,699.5,MCDRNUM)="31.5///`"_MCCONTYP,MCDRNUM=MCDRNUM+1
80 I $P($G(^AUPNVSIT(+$P(MCDATA("PCC"),U),0)),U)]"" S DR(1,699.5,MCDRNUM)="900////"_+$P(MCDATA("PCC"),U),MCDRNUM=MCDRNUM+1
81 S ORIFN=+$P(MCDATA("OR"),U),GMRCO=+$P(MCDATA("OR"),U,2)
82 I $P($G(^OR(100,ORIFN,0)),U)]"" S DR(1,699.5,MCDRNUM)="1000////"_ORIFN,MCDRNUM=MCDRNUM+1
83 I $P($G(^GMR(123,GMRCO,0)),U)]"" S DR(1,699.5,MCDRNUM)="1001////"_GMRCO,MCDRNUM=MCDRNUM+1
84 F MCPIECE=1:1:16 D
85 . S MCDATA=$P(MCDATA("ES"),U,MCPIECE) Q:MCDATA=""
86 . S MCSLASH="///"
87 . I "^1^4^13^"[(U_MCPIECE_U) S MCSLASH=MCSLASH_"`" I $P($G(^VA(200,+MCDATA,0)),U)="" Q
88 . I "^2^5^"[(U_MCPIECE_U) D
89 .. S MCVALCOD(MCPIECE)=$E(MCDATA,1,40)
90 .. S MCSLASH=MCSLASH_"^S X="
91 .. S MCDATA="MCVALCOD("_MCPIECE_")"
92 .. Q
93 . I 7=MCPIECE I "^D^PD^RV^ROV^RNV^S^SRV^SROV^"'[(U_MCDATA_U) Q
94 . I 10=MCPIECE I MCDATA<0!(MCDATA>999999999) Q
95 . I 11=MCPIECE I MCDATA<0!(MCDATA>99999999999999) Q
96 . I 16=MCPIECE I MCDATA<0!(MCDATA>999) Q
97 . I 14=MCPIECE S X=MCDATA,%DT="TX" D ^%DT S MCDATA=Y
98 . I "^3^6^8^9^14^15^"[(U_MCPIECE_U) Q:MCDATA\1'?7N
99 . I 12=MCPIECE I MCDATA'=1 Q
100 . S DR(1,699.5,MCDRNUM)=(1499+MCPIECE)_MCSLASH_MCDATA
101 . S MCDRNUM=MCDRNUM+1
102 . Q
103 S DIE="^MCAR(699.5,",DA=MC6995D0 D ^DIE ; ALL FLAT FIELDS
104 ;
105 D ^MCPOS04A ; MULTIPLES
106 Q
Note: See TracBrowser for help on using the repository browser.