Routine: MCPOS0A

MCPOS0A ;HIRMFO/RMP,DAD-TERM:SUBSPECIALTY ALLIGNER ;5/1/96  13:29

 ;;2.3;Medicine;;09/13/1996

 D STUFF("MCPTF",694.8)

 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

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

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCPOS0A   1902     printed  Feb 18, 2025@23:42:58                                                                                                                                                                                                     Page 2

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

MCPOS0A.m