| 1 | MCPOS0A ;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
|
|---|
| 17 | CODE(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 | ;
|
|---|
| 28 | STUFF(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 | ;
|
|---|
| 48 | SCODE(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"
|
|---|
| 55 | DIC . 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
|
|---|
