AMQQLKUP.m

AMQQLKUP ; IHS/CMI/THL - LOOKS AT STANDARD TABLE OF CLINICAL ENTRIES FOR DFN ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

EN ; - EP - FROM AMQQMULT

 N AMQQLK,AMQQLK1,AMQQPTR,AMQQPTG,AMQQTMP,AMQQL,AMQQDFNS

 S AMQQLK=@(U_AMQQGR_"(0)")

 S AMQQLK1=+$P(AMQQLK,U,2)

 S AMQQPTR=+$P($P(^DD(AMQQLK1,.01,0),U,2),"P",2)

 I $E($P(^DIC(AMQQPTR,0,"GL"),"^",2),1,4)'="AUTT" Q

 S AMQQPTG=^DIC(AMQQPTR,0,"GL")

 ; Find DFN of AUTT entry given standard IHS code

 S AMQQDFNS=""

 F AMQQL=1:1 S AMQQTMP=$P(AMQQID,":",AMQQL) Q:AMQQTMP=""  D

 .S AMQQTMP=$O(@(AMQQPTG_"""C"","""_AMQQTMP_""","""")"))

 .S AMQQDFNS=AMQQDFNS_AMQQTMP_":"

 S AMQQLKUP(AMQQGR,AMQQID)=$E(AMQQDFNS,1,$L(AMQQDFNS)-1)

 Q

AMQQLKUP  ; IHS/CMI/THL - LOOKS AT STANDARD TABLE OF CLINICAL ENTRIES FOR DFN ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

EN        ; - EP - FROM AMQQMULT

 +1        NEW AMQQLK,AMQQLK1,AMQQPTR,AMQQPTG,AMQQTMP,AMQQL,AMQQDFNS

 +2        SET AMQQLK=@(U_AMQQGR_"(0)")

 +3        SET AMQQLK1=+$PIECE(AMQQLK,U,2)

 +4        SET AMQQPTR=+$PIECE($PIECE(^DD(AMQQLK1,.01,0),U,2),"P",2)

 +5        IF $EXTRACT($PIECE(^DIC(AMQQPTR,0,"GL"),"^",2),1,4)'="AUTT"

               QUIT 

 +6        SET AMQQPTG=^DIC(AMQQPTR,0,"GL")

 +7       ; Find DFN of AUTT entry given standard IHS code

 +8        SET AMQQDFNS=""

 +9        FOR AMQQL=1:1

               SET AMQQTMP=$PIECE(AMQQID,":",AMQQL)

               IF AMQQTMP=""

                   QUIT 

               Begin DoDot:1

 +10               SET AMQQTMP=$ORDER(@(AMQQPTG_"""C"","""_AMQQTMP_""","""")"))

 +11               SET AMQQDFNS=AMQQDFNS_AMQQTMP_":"

               End DoDot:1

 +12       SET AMQQLKUP(AMQQGR,AMQQID)=$EXTRACT(AMQQDFNS,1,$LENGTH(AMQQDFNS)-1)

 +13       QUIT