MCPOS0A ;HIRMFO/RMP,DAD-TERM:SUBSPECIALTY ALLIGNER ;5/1/96 13:29
;;2.3;Medicine;;09/13/1996
;
D STUFF("MCPTF",694.8)
Q
;
N COUNT,TEMP,REC,PROC,CODE
S COUNT=0,TEMP=""
F S TEMP=$O(^MCAR(694.8,"B",TEMP)) Q:TEMP="" D
. S REC=$O(^MCAR(694.8,"B",TEMP,""))
. S COUNT=COUNT+1
. S CODE=$S($D(^MCAR(694.8,REC,1)):$$CODE(REC),1:"")
. S PROC=$S($D(^MCAR(694.8,REC,2)):$P(^MCAR(697.2,^(2),0),U),1:"")
. W !,";;",$P(^MCAR(694.8,REC,0),U)_"^"_CODE_"^"_PROC
. Q
Q
CODE(REC) ;
N CNT,ARRAY,TEMP,SUBENTRY
S CNT=0,(ARRAY)=""
F S CNT=$O(^MCAR(694.8,REC,1,CNT)) Q:CNT'?1N.N D
. S TEMP=^MCAR(694.8,REC,1,CNT,0),SUBENTRY=""
. S SUBENTRY=$TR($P(TEMP,U,1,3),U,"~")
. S:$L(ARRAY)>0 ARRAY=ARRAY_","
. S ARRAY=ARRAY_SUBENTRY
. Q
Q ARRAY
;
STUFF(ROUTINE,TFILE) ;routine is set to "MCPTF" and TFILE is
;set to 694.8
N TEMP,COUNT,HOLD,VALUE,LOOP,MCDATA
S MCDATA(1)=""
S MCDATA(2)="Update the pointers from the Procedure Term file (#694.8)"
S MCDATA(3)="to the Procedure/Subspecialty file (#697.2)."
D MES^XPDUTL(.MCDATA)
;
F LOOP=1:1 S HOLD=$P($T(DATA+LOOP^@(ROUTINE)),";;",2) Q:HOLD="" D
. S (DIC,DLAYGO)=TFILE,DIC(0)="L"
. S (VALUE,X)=$P(HOLD,U)
. D ^DIC I Y=-1 K DIC,DA Q
. S DA=+Y
. S MCPRO=$P(HOLD,U,3),DIE=DIC K DIC
. S DR=".01///^S X=VALUE;9///^S X=MCPRO"
. D ^DIE
. D SCODE($P(HOLD,U,2),DA,TFILE)
. Q
Q
;
SCODE(STEMP,SDA,FILE) ;
N ENTRY,CODE,TYPE,DATE,LOOP
F LOOP=1:1 S ENTRY=$P(STEMP,",",LOOP) Q:ENTRY="" D
. K DD,DIC,DINUM,DO
. S DA(1)=SDA,DIC="^MCAR("_FILE_","_DA(1)_",1,",DIC(0)="L"
. S DIC("P")=$$GET1^DID(FILE,3,"","SPECIFIER"),DLAYGO=FILE
. S (X,CODE)=$P(ENTRY,"~"),D="B"
DIC . D IX^DIC I Y=-1 D FILE^DICN
. I Y=-1 K DIC,DA Q
. S DIE=DIC,DA=+Y K DIC
. S TYPE=$P(ENTRY,"~",2)
. S DATE=$P(ENTRY,"~",3)
. S DR=".01////^S X=CODE;.02///^S X=TYPE;.03///^S X=DATE"
. D ^DIE
. K DIE,DR,DA,Y
. Q
Q
MCPOS0A ;HIRMFO/RMP,DAD-TERM:SUBSPECIALTY ALLIGNER ;5/1/96 13:29
+1 ;;2.3;Medicine;;09/13/1996
+2 ;
+3 DO STUFF("MCPTF",694.8)
+4 QUIT
+5 ;
+6 NEW COUNT,TEMP,REC,PROC,CODE
+7 SET COUNT=0
SET TEMP=""
+8 FOR
SET TEMP=$ORDER(^MCAR(694.8,"B",TEMP))
IF TEMP=""
QUIT
Begin DoDot:1
+9 SET REC=$ORDER(^MCAR(694.8,"B",TEMP,""))
+10 SET COUNT=COUNT+1
+11 SET CODE=$SELECT($DATA(^MCAR(694.8,REC,1)):$$CODE(REC),1:"")
+12 SET PROC=$SELECT($DATA(^MCAR(694.8,REC,2)):$PIECE(^MCAR(697.2,^(2),0),U),1:"")
+13 WRITE !,";;",$PIECE(^MCAR(694.8,REC,0),U)_"^"_CODE_"^"_PROC
+14 QUIT
End DoDot:1
+15 QUIT
CODE(REC) ;
+1 NEW CNT,ARRAY,TEMP,SUBENTRY
+2 SET CNT=0
SET (ARRAY)=""
+3 FOR
SET CNT=$ORDER(^MCAR(694.8,REC,1,CNT))
IF CNT'?1N.N
QUIT
Begin DoDot:1
+4 SET TEMP=^MCAR(694.8,REC,1,CNT,0)
SET SUBENTRY=""
+5 SET SUBENTRY=$TRANSLATE($PIECE(TEMP,U,1,3),U,"~")
+6 IF $LENGTH(ARRAY)>0
SET ARRAY=ARRAY_","
+7 SET ARRAY=ARRAY_SUBENTRY
+8 QUIT
End DoDot:1
+9 QUIT ARRAY
+10 ;
STUFF(ROUTINE,TFILE) ;routine is set to "MCPTF" and TFILE is
+1 ;set to 694.8
+2 NEW TEMP,COUNT,HOLD,VALUE,LOOP,MCDATA
+3 SET MCDATA(1)=""
+4 SET MCDATA(2)="Update the pointers from the Procedure Term file (#694.8)"
+5 SET MCDATA(3)="to the Procedure/Subspecialty file (#697.2)."
+6 DO MES^XPDUTL(.MCDATA)
+7 ;
+8 FOR LOOP=1:1
SET HOLD=$PIECE($TEXT(DATA+LOOP^@(ROUTINE)),";;",2)
IF HOLD=""
QUIT
Begin DoDot:1
+9 SET (DIC,DLAYGO)=TFILE
SET DIC(0)="L"
+10 SET (VALUE,X)=$PIECE(HOLD,U)
+11 DO ^DIC
IF Y=-1
KILL DIC,DA
QUIT
+12 SET DA=+Y
+13 SET MCPRO=$PIECE(HOLD,U,3)
SET DIE=DIC
KILL DIC
+14 SET DR=".01///^S X=VALUE;9///^S X=MCPRO"
+15 DO ^DIE
+16 DO SCODE($PIECE(HOLD,U,2),DA,TFILE)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
SCODE(STEMP,SDA,FILE) ;
+1 NEW ENTRY,CODE,TYPE,DATE,LOOP
+2 FOR LOOP=1:1
SET ENTRY=$PIECE(STEMP,",",LOOP)
IF ENTRY=""
QUIT
Begin DoDot:1
+3 KILL DD,DIC,DINUM,DO
+4 SET DA(1)=SDA
SET DIC="^MCAR("_FILE_","_DA(1)_",1,"
SET DIC(0)="L"
+5 SET DIC("P")=$$GET1^DID(FILE,3,"","SPECIFIER")
SET DLAYGO=FILE
+6 SET (X,CODE)=$PIECE(ENTRY,"~")
SET D="B"
DIC DO IX^DIC
IF Y=-1
DO FILE^DICN
+1 IF Y=-1
KILL DIC,DA
QUIT
+2 SET DIE=DIC
SET DA=+Y
KILL DIC
+3 SET TYPE=$PIECE(ENTRY,"~",2)
+4 SET DATE=$PIECE(ENTRY,"~",3)
+5 SET DR=".01////^S X=CODE;.02///^S X=TYPE;.03///^S X=DATE"
+6 DO ^DIE
+7 KILL DIE,DR,DA,Y
+8 QUIT
End DoDot:1
+9 QUIT
