source: WorldVistAEHR/trunk/r/MEDICINE-MC/MCPOS0A.m@ 1766

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

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1MCPOS0A ;HIRMFO/RMP,DAD-TERM:SUBSPECIALTY ALLIGNER ;5/1/96 13:29
2 ;;2.3;Medicine;;09/13/1996
3 ;
4 D STUFF("MCPTF",694.8)
5 Q
6 ;
7 N COUNT,TEMP,REC,PROC,CODE
8 S COUNT=0,TEMP=""
9 F S TEMP=$O(^MCAR(694.8,"B",TEMP)) Q:TEMP="" D
10 . S REC=$O(^MCAR(694.8,"B",TEMP,""))
11 . S COUNT=COUNT+1
12 . S CODE=$S($D(^MCAR(694.8,REC,1)):$$CODE(REC),1:"")
13 . S PROC=$S($D(^MCAR(694.8,REC,2)):$P(^MCAR(697.2,^(2),0),U),1:"")
14 . W !,";;",$P(^MCAR(694.8,REC,0),U)_"^"_CODE_"^"_PROC
15 . Q
16 Q
17CODE(REC) ;
18 N CNT,ARRAY,TEMP,SUBENTRY
19 S CNT=0,(ARRAY)=""
20 F S CNT=$O(^MCAR(694.8,REC,1,CNT)) Q:CNT'?1N.N D
21 . S TEMP=^MCAR(694.8,REC,1,CNT,0),SUBENTRY=""
22 . S SUBENTRY=$TR($P(TEMP,U,1,3),U,"~")
23 . S:$L(ARRAY)>0 ARRAY=ARRAY_","
24 . S ARRAY=ARRAY_SUBENTRY
25 . Q
26 Q ARRAY
27 ;
28STUFF(ROUTINE,TFILE) ;routine is set to "MCPTF" and TFILE is
29 ;set to 694.8
30 N TEMP,COUNT,HOLD,VALUE,LOOP,MCDATA
31 S MCDATA(1)=""
32 S MCDATA(2)="Update the pointers from the Procedure Term file (#694.8)"
33 S MCDATA(3)="to the Procedure/Subspecialty file (#697.2)."
34 D MES^XPDUTL(.MCDATA)
35 ;
36 F LOOP=1:1 S HOLD=$P($T(DATA+LOOP^@(ROUTINE)),";;",2) Q:HOLD="" D
37 . S (DIC,DLAYGO)=TFILE,DIC(0)="L"
38 . S (VALUE,X)=$P(HOLD,U)
39 . D ^DIC I Y=-1 K DIC,DA Q
40 . S DA=+Y
41 . S MCPRO=$P(HOLD,U,3),DIE=DIC K DIC
42 . S DR=".01///^S X=VALUE;9///^S X=MCPRO"
43 . D ^DIE
44 . D SCODE($P(HOLD,U,2),DA,TFILE)
45 . Q
46 Q
47 ;
48SCODE(STEMP,SDA,FILE) ;
49 N ENTRY,CODE,TYPE,DATE,LOOP
50 F LOOP=1:1 S ENTRY=$P(STEMP,",",LOOP) Q:ENTRY="" D
51 . K DD,DIC,DINUM,DO
52 . S DA(1)=SDA,DIC="^MCAR("_FILE_","_DA(1)_",1,",DIC(0)="L"
53 . S DIC("P")=$$GET1^DID(FILE,3,"","SPECIFIER"),DLAYGO=FILE
54 . S (X,CODE)=$P(ENTRY,"~"),D="B"
55DIC . D IX^DIC I Y=-1 D FILE^DICN
56 . I Y=-1 K DIC,DA Q
57 . S DIE=DIC,DA=+Y K DIC
58 . S TYPE=$P(ENTRY,"~",2)
59 . S DATE=$P(ENTRY,"~",3)
60 . S DR=".01////^S X=CODE;.02///^S X=TYPE;.03///^S X=DATE"
61 . D ^DIE
62 . K DIE,DR,DA,Y
63 . Q
64 Q
Note: See TracBrowser for help on using the repository browser.