XTLKKWL.m

XTLKKWL ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC - LOOKUP DRIVER PROGRAM FOR "AND"ING INVERTED SEARCH ;07/22/93  15:46 [ 04/02/2003   8:47 AM ]

 ;;7.3;TOOLKIT;**1001**;APR 1, 2003

 ;;7.3;TOOLKIT;;Apr 25, 1995

 ;THIS ROUTINE CONTAINS IHS MODIFICATIONS BY IHS/ANMC/FDB-9/5/96

 ;AND TASSC/MFD

 ; ASSUMES XTLKKSCH("TYPE"),("GBL"),("INDEX") AND XTLKX

 S XTLKXSAV=XTLKX

 K Y

 S XTLKGBL=XTLKKSCH("GBL"),XTLKL=XTLKX

 S XTLKASK=$S('$D(DIC(0)):1,DIC(0)["E":1,1:0)

 I $G(XTLKSAY)="" S XTLKSAY=1

 ;----- BEGIN IHS MODIFICATION

 ;ORIGINAL MODIFICATIONS BY IHS/ANMC/FDB-9/5/96 AND TASSC/MFD

 ;LINE INIT IS COMMENTED OUT

INIT ;I XTLKGBL'["^",XTLKGBL'?1N.N,XTLKGBL'?1N.N1"."1N.N S XTLKGBL=$O(^DIC("B",XTLKGBL,""))  ;IHS/ANMC/FDB-9/5/96-ORIGINAL LINE-COMMENTED OUT

 ;ADD NEW LINE:

 I $L(XTLKGBL,"@")>2 S XTLKGBL=@($P(XTLKGBL,"@",2))  S:XTLKGBL'["(" XTLKGBL=XTLKGBL_"("  ;IHS/ANMC/FDB-9/5/96-ADDED LINE-PATCH FOR DOUBLY-INDIRECT AMQQ GLOBAL ROOTS BEING PASSED IN DIC

 ;NEXT LINE IS COMMENTED OUT AND REPLACED BY NEW LINE

 ;I XTLKGBL'["^",XTLKGBL'?1N.N"."?1N.N1"."1N.N S XTLKGBL=$O(^DIC("B",XTLKGBL,""))

 I XTLKGBL'["^",XTLKGBL'?1N.N,XTLKGBL'?1N.N1"."1N.N S XTLKGBL=$O(^DIC("B",XTLKGBL,""))   ;TASSC/MFD changed line to equal INIT and get rid of syntax error in the line above

 ;----- END IHS MODIFICATION

 S:XTLKGBL'["^" XTLKGBL=^DIC(XTLKGBL,0,"GL")

 S XTLKREF=XTLKGBL_""""_XTLKKSCH("INDEX")_""",XTLKWD)"

 S XTLKREF1=XTLKGBL

 S XTLKREF2=$E(XTLKREF,1,$L(XTLKREF)-1)_","""")"

 S XTLKREF3=XTLKGBL_"^TMP(""XTLKHITS"",$J,XTLKH),0)"

 S XTLKREF4=$E(XTLKREF,1,$L(XTLKREF)-1)_",XTLKD)"

 ; NOTE: CHKSHRT HAS BEEN CHANGED TO USE "AB" BECAUSE THE

 ;       B INDEX NO LONGER EXISTS FOR ICD FILES -- NEEDS TO

 ;       BE IMPROVED TO PRESERVE GENERALITY OF LOOKUP!!!

CHKSHRT G:'$D(^XT(8984.2,"AC",$P(XTLKREF1,U,2),XTLKL)) NOTSHRT S XTLKI=$O(^(XTLKL,"")),XTLKL=$P($P(^XT(8984.2,XTLKI,0),U,2),";") S Y=$S(XTLKREF1'[$P($P(^XT(8984.2,XTLKI,0),U,2),";",2):-1,$D(@(XTLKREF1_"XTLKL,0)")):XTLKL,1:-1)

 G:Y<1 NOTSHRT

 I $D(@(XTLKREF1_"Y,0)")) X:$D(DIC("S")) DIC("S") E  S Y=-1

 G:Y<1 NOTSHRT

 K ^TMP("XTLKHITS",$J) S ^TMP("XTLKHITS",$J)=1,^TMP("XTLKHITS",$J,1)=Y G VERIFY

NOTSHRT ;

 G NOTSHRT^XTLKKWL1

VERIFY ;

 G VERIFY^XTLKKWL1

XTLKKWL   ; IHS/OHPRD/ACC,ALB/JLU,SFISC/JC - LOOKUP DRIVER PROGRAM FOR "AND"ING INVERTED SEARCH ;07/22/93  15:46 [ 04/02/2003   8:47 AM ]

 +1       ;;7.3;TOOLKIT;**1001**;APR 1, 2003

 +2       ;;7.3;TOOLKIT;;Apr 25, 1995

 +3       ;THIS ROUTINE CONTAINS IHS MODIFICATIONS BY IHS/ANMC/FDB-9/5/96

 +4       ;AND TASSC/MFD

 +5       ; ASSUMES XTLKKSCH("TYPE"),("GBL"),("INDEX") AND XTLKX

 +6        SET XTLKXSAV=XTLKX

 +7        KILL Y

 +8        SET XTLKGBL=XTLKKSCH("GBL")

           SET XTLKL=XTLKX

 +9        SET XTLKASK=$SELECT('$DATA(DIC(0)):1,DIC(0)["E":1,1:0)

 +10       IF $GET(XTLKSAY)=""

               SET XTLKSAY=1

 +11      ;----- BEGIN IHS MODIFICATION

 +12      ;ORIGINAL MODIFICATIONS BY IHS/ANMC/FDB-9/5/96 AND TASSC/MFD

 +13      ;LINE INIT IS COMMENTED OUT

INIT      ;I XTLKGBL'["^",XTLKGBL'?1N.N,XTLKGBL'?1N.N1"."1N.N S XTLKGBL=$O(^DIC("B",XTLKGBL,""))  ;IHS/ANMC/FDB-9/5/96-ORIGINAL LINE-COMMENTED OUT

 +1       ;ADD NEW LINE:

 +2       ;IHS/ANMC/FDB-9/5/96-ADDED LINE-PATCH FOR DOUBLY-INDIRECT AMQQ GLOBAL ROOTS BEING PASSED IN DIC

           IF $LENGTH(XTLKGBL,"@")>2

               SET XTLKGBL=@($PIECE(XTLKGBL,"@",2))

               IF XTLKGBL'["("

                   SET XTLKGBL=XTLKGBL_"("

 +3       ;NEXT LINE IS COMMENTED OUT AND REPLACED BY NEW LINE

 +4       ;I XTLKGBL'["^",XTLKGBL'?1N.N"."?1N.N1"."1N.N S XTLKGBL=$O(^DIC("B",XTLKGBL,""))

 +5       ;TASSC/MFD changed line to equal INIT and get rid of syntax error in the line above

           IF XTLKGBL'["^"

               IF XTLKGBL'?1N.N

                   IF XTLKGBL'?1N.N1"."1N.N

                       SET XTLKGBL=$ORDER(^DIC("B",XTLKGBL,""))

 +6       ;----- END IHS MODIFICATION

 +7        IF XTLKGBL'["^"

               SET XTLKGBL=^DIC(XTLKGBL,0,"GL")

 +8        SET XTLKREF=XTLKGBL_""""_XTLKKSCH("INDEX")_""",XTLKWD)"

 +9        SET XTLKREF1=XTLKGBL

 +10       SET XTLKREF2=$EXTRACT(XTLKREF,1,$LENGTH(XTLKREF)-1)_","""")"

 +11       SET XTLKREF3=XTLKGBL_"^TMP(""XTLKHITS"",$J,XTLKH),0)"

 +12       SET XTLKREF4=$EXTRACT(XTLKREF,1,$LENGTH(XTLKREF)-1)_",XTLKD)"

 +13      ; NOTE: CHKSHRT HAS BEEN CHANGED TO USE "AB" BECAUSE THE

 +14      ;       B INDEX NO LONGER EXISTS FOR ICD FILES -- NEEDS TO

 +15      ;       BE IMPROVED TO PRESERVE GENERALITY OF LOOKUP!!!

CHKSHRT    IF '$DATA(^XT(8984.2,"AC",$PIECE(XTLKREF1,U,2),XTLKL))

               GOTO NOTSHRT

           SET XTLKI=$ORDER(^(XTLKL,""))

           SET XTLKL=$PIECE($PIECE(^XT(8984.2,XTLKI,0),U,2),";")

           SET Y=$SELECT(XTLKREF1'[$PIECE($PIECE(^XT(8984.2,XTLKI,0),U,2),";",2):-1,$DATA(@(XTLKREF1_"XTLKL,0)")):XTLKL,1:-1)

 +1        IF Y<1

               GOTO NOTSHRT

 +2        IF $DATA(@(XTLKREF1_"Y,0)"))

               IF $DATA(DIC("S"))

                   XECUTE DIC("S")

              IF '$TEST

                   SET Y=-1

 +3        IF Y<1

               GOTO NOTSHRT

 +4        KILL ^TMP("XTLKHITS",$JOB)

           SET ^TMP("XTLKHITS",$JOB)=1

           SET ^TMP("XTLKHITS",$JOB,1)=Y

           GOTO VERIFY

NOTSHRT   ;

 +1        GOTO NOTSHRT^XTLKKWL1

VERIFY    ;

 +1        GOTO VERIFY^XTLKKWL1