Routine: APCLDF

APCLDF ; IHS/CMI/LAB - YRULER<->PCC INTERFACE ;

 ;;2.0;IHS PCC SUITE;**5,10**;MAY 14, 2009;Build 88

 ;The above line will be changed to be nonparameter as of the

 ;next version of this package.  All callers should enter this

 ;routine at entry point START1^APCLDF(,,,)

 ;FIRST LINE PARAMETER PASS OKAY'ED BY SAC COMMITTEE TO ALLOW OTHER PACKAGES TO CHANGE THEIR CALLS

 G START2

START1(APCLX,APCLY,APCLINT,APCLTYPE) ;PEP - PUBLISHED ENTRY POINT - main entry point for data fetcher utility

START2 ;

 ; input vars via parameter pass (required):

 ; APCLX - contains the pt dfn^script

 ; APCLY - contains the array in which results to be sent back in

 ; ** IT IS THE RESPONSIBILITY OF THE CALLER TO KILL THE ARRAY

 ; ** PRIOR TO CALLING THIS ROUTINE

 ; input vars via parameter pass :

 ; APCLINT - set to 1 to invoke interactive mode

 ;         - set to 0 or do not pass for background mode

 ; output vars:

 ; 1. APCLTYPE - returned (if APCLINT set) with file type, NV, D, etc.

 ; 2. ARRAY designated by caller (will be undefined if no hits or if

 ; error) note: array var will exist if demo. info asked for and

 ; value is null

 ; 3. APCLER - if error, set to a code delineated in APCLDF2, returned

 ; as value of function

 ; 4. APCLTYPE - returned with value of file type D, NV, or V

 ; (if APCLINT was set=1 and caller called by reference)

START ;

 NEW %,C,D,E,I,N,X,Y,Z,COND,FILE,FLD,FN,HIT,LINE,LKUP,NUM,NVAL,PAT,SCRN,STP,TABLE,TAX,TVAL,TVAL2,TYPE,VAL,XREF,APCLTX,BOOL,DATE,STDATE,EDATE,APCLFILE,APCLER,DIC,B

 I '$D(APCLX) S APCLER=1 G XIT

 I '$D(APCLY) S APCLER=2 G XIT

 I $G(APCLINT) S APCLINT=""

 E  K APCLINT

 D SETUP I $D(APCLER) G XIT

 I $E("PATIENT",1,$L($P(X," ")))=$P(X," ")!($P(X," ")="PT") D D^APCLDF4 G XIT

 D PARSE^APCLDF1

 D SET

 I $D(APCLER) G XIT

 D PROCESS^APCLDF1

XIT ;

 K ^TMP("APCLDF",$J),^TMP("APCLTAX",$J)

 I '$D(APCLER) S APCLER=0

 Q APCLER

SETUP ;

 K ^TMP("APCLDF",$J),^TMP("APCLTAX",$J),APCLER

 S U="^"

 NEW % F %=1:1:$L(APCLX) S:$E(APCLX,%)?1L APCLX=$E(APCLX,0,%-1)_$C($A(APCLX,%)-32)_$E(APCLX,%+1,999)

 S PAT=$P(APCLX,U),X=$P(APCLX,U,2)

 I X="" S APCLER=6

SET ;

 ; Rosetta Stone for the text line is:

 ; FILE;TYPE;LOOKUP GLOBAL;PCC GLOBAL;SCREEN;QMAN TERM FOR TAXONOMY;TABLE XREF;SAVED;SAVED;SYNONYM;SYNONYM;SYNONYM

 ;F I=1:1 S:$T(LKUP+I)=""&('$D(HIT)) APCLER=5 Q:$D(APCLER)!($T(LKUP+I)="")  I $E($P($T(LKUP+I),";",3),1,$L(FILE))=FILE!($P($T(LKUP+I),";",12,99)[FILE) S:$D(HIT) APCLER=12 S HIT=I K APCLHIT

 F I=1:1 S:$T(LKUP+I)=""&('$D(HIT)) APCLER=5 Q:$D(APCLER)!($T(LKUP+I)="")  D  I $E($P($T(LKUP+I),";",3),1,$L(FILE))=FILE!$D(APCLHIT) S:$D(HIT) APCLER=12 S HIT=I K APCLHIT

 . NEW APCLI

 . F APCLI=12:1:99 Q:$P($T(LKUP+I),";",APCLI)=""!$D(APCLHIT)  S APCLTXT=$P($T(LKUP+I),";",APCLI) I $E(APCLTXT,1,$L(FILE))=FILE S APCLHIT="" Q

 . K APCLTXT

 I $D(APCLER) G X1

 S LINE=$P($T(LKUP+HIT),";",3,99)

 I $D(APCLINT) S APCLFILE=$P(LINE,";")

 S TYPE=$P(LINE,";",2)

 I $D(APCLINT) S APCLTYPE=TYPE

 S TABLE=$P(LINE,";",3)

 S LKUP=$P(LINE,";",4)

 I $D(APCLINT) S APCLFILE=$P(@LKUP@(0),U)

 S SCRN=$P(LINE,";",5)

 S TAX=$P(LINE,";",6)

 I TAX="",(VAL["["!(VAL="*")) S APCLER=3 G X1

 I VAL="*",TAX]"",$D(APCLINT) D TAX

 S XREF=$P(LINE,";",7)

X1 Q

TAX ; User may create a taxonomy if they choose

 S X=TAX,DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC I Y=-1 S APCLER=7 G X5

 S X=+Y D EN1^AMQQTX I '$D(^UTILITY("AMQQ TAX",$J)) S APCLER=11 G X5

 I $G(AMQQTDFN)>0 S VAL="["_$P(^ATXAX(AMQQTDFN,0),U)_"]"

 I $D(^UTILITY("AMQQ TAX",$J)) D

 . S T=$O(^UTILITY("AMQQ TAX",$J,""))

 . F TX=0:0 S TX=$O(^UTILITY("AMQQ TAX",$J,T,TX)) Q:'TX  S ^TMP("APCLTAX",$J,TX)=""

 . K ^UTILITY("AMQQ TAX")

 K AMQQCCLS,AMQQCNAM,AMQQDF,AMQQQ,AMQQTAX,AMQQURGN,AMQQTDFN,AMQQQUIT,AMQQECHO,AMQQGTX,AMQQTAXT,AMQQTGBL

X5 Q

LKUP ; D=Demographic, VI="AA" xref doesn't include .01 ptr val, VV does, NV is non-"V" file,VISIT=VISIT file

 ;;PURPOSE OF VISITS;VI;^ICD9;^AUPNVPOV;;DIAGNOSIS;BA;;;POV;DX;DIAGNOSIS

 ;;DENTAL SERVICES;VI;^AUTTADA;^AUPNVDEN;;ADA CODE;BA;;;ADA CODE

 ;;EXAMINATIONS;VV;^AUTTEXAM;^AUPNVXAM;;;B;;;EXAMS

 ;;VISIT;VISIT;;^AUPNVSIT;;;B;;;VISITS

 ;;MEDICATIONS;VI;^PSDRUG;^AUPNVMED;;RX;B;;;RX;MEDS

 ;;LABS;VV;^LAB(60);^AUPNVLAB;;LAB TAX;B;;;LABORATORY;LAB TESTS

 ;;MEASUREMENTS;VV;^AUTTMSR;^AUPNVMSR;;;B

 ;;PROCEDURES;VI;^ICD0;^AUPNVPRC;;PROCEDURE (MEDICAL);BA;;;

 ;;SKIN TESTS;VV;^AUTTSK;^AUPNVSK;;;B

 ;;IMMUNIZATIONS;VV;^AUTTIMM;^AUPNVIMM;;;B

 ;;DIAGNOSTIC PROCEDURE;VV;^AUTTDXPR;^AUPNVDXP;;;B

 ;;RADIOLOGY;VV;^RAMIS(71);^AUPNVRAD;;;B;;;XRAY;FILMS;RADIOLOGY STUDIES

 ;;EDUCATION;VI;^AUTTEDT;^AUPNVPED;;PATIENT ED TOPIC;B;;;PT EDUCATION;EDUCATION TOPICS;PATIENT ED

 ;;ACTIVE PROBLEMS;NV;^ICD9;^AUPNPROB;I $P(@LKUP@(D,0),U,12)'="D",$P(@LKUP@(D,0),U,12)'="I";PROBLEM LIST DIAGNOSIS;BA

 ;;PROBLEMS;NV;^ICD9;^AUPNPROB;I $P(@LKUP@(D,0),U,12)'="D";PROBLEM LIST DIAGNOSIS;BA

 ;;INACTIVE PROBLEMS;NV;^ICD9;^AUPNPROB;I $P(@LKUP@(D,0),U,12)="I";PROBLEM LIST DIAGNOSIS;BA

 ;;FAMILY HISTORY;NV;^ICD9;^AUPNFH;;DIAGNOSIS;BA

 ;;PERSONAL HISTORY;NV;^ICD9;^AUPNPH;;DIAGNOSIS;BA

 ;;HLTH STATUS;NV;^AUTTHF;^AUPNHF;;HEALTH FACTORS;B

 ;;HEALTH FACTORS;VV;^AUTTHF;^AUPNVHF;;HEALTH FACTORS;B;;;HEALTH STATUS

APCLDF    ; IHS/CMI/LAB - YRULER<->PCC INTERFACE ;

 +1       ;;2.0;IHS PCC SUITE;**5,10**;MAY 14, 2009;Build 88

 +2       ;The above line will be changed to be nonparameter as of the

 +3       ;next version of this package.  All callers should enter this

 +4       ;routine at entry point START1^APCLDF(,,,)

 +5       ;FIRST LINE PARAMETER PASS OKAY'ED BY SAC COMMITTEE TO ALLOW OTHER PACKAGES TO CHANGE THEIR CALLS

 +6       ;

 +7        GOTO START2

 +8       ;

START1(APCLX,APCLY,APCLINT,APCLTYPE) ;PEP - PUBLISHED ENTRY POINT - main entry point for data fetcher utility

START2    ;

 +1       ;

 +2       ; input vars via parameter pass (required):

 +3       ; APCLX - contains the pt dfn^script

 +4       ; APCLY - contains the array in which results to be sent back in

 +5       ; ** IT IS THE RESPONSIBILITY OF THE CALLER TO KILL THE ARRAY

 +6       ; ** PRIOR TO CALLING THIS ROUTINE

 +7       ;

 +8       ; input vars via parameter pass :

 +9       ; APCLINT - set to 1 to invoke interactive mode

 +10      ;         - set to 0 or do not pass for background mode

 +11      ;

 +12      ; output vars:

 +13      ; 1. APCLTYPE - returned (if APCLINT set) with file type, NV, D, etc.

 +14      ; 2. ARRAY designated by caller (will be undefined if no hits or if

 +15      ; error) note: array var will exist if demo. info asked for and

 +16      ; value is null

 +17      ; 3. APCLER - if error, set to a code delineated in APCLDF2, returned

 +18      ; as value of function

 +19      ; 4. APCLTYPE - returned with value of file type D, NV, or V

 +20      ; (if APCLINT was set=1 and caller called by reference)

 +21      ;

START     ;

 +1        NEW %,C,D,E,I,N,X,Y,Z,COND,FILE,FLD,FN,HIT,LINE,LKUP,NUM,NVAL,PAT,SCRN,STP,TABLE,TAX,TVAL,TVAL2,TYPE,VAL,XREF,APCLTX,BOOL,DATE,STDATE,EDATE,APCLFILE,APCLER,DIC,B

 +2        IF '$DATA(APCLX)

               SET APCLER=1

               GOTO XIT

 +3        IF '$DATA(APCLY)

               SET APCLER=2

               GOTO XIT

 +4        IF $GET(APCLINT)

               SET APCLINT=""

 +5       IF '$TEST

               KILL APCLINT

 +6        DO SETUP

           IF $DATA(APCLER)

               GOTO XIT

 +7        IF $EXTRACT("PATIENT",1,$LENGTH($PIECE(X," ")))=$PIECE(X," ")!($PIECE(X," ")="PT")

               DO D^APCLDF4

               GOTO XIT

 +8        DO PARSE^APCLDF1

 +9        DO SET

 +10       IF $DATA(APCLER)

               GOTO XIT

 +11       DO PROCESS^APCLDF1

XIT       ;

 +1        KILL ^TMP("APCLDF",$JOB),^TMP("APCLTAX",$JOB)

 +2        IF '$DATA(APCLER)

               SET APCLER=0

 +3        QUIT APCLER

 +4       ;

SETUP     ;

 +1        KILL ^TMP("APCLDF",$JOB),^TMP("APCLTAX",$JOB),APCLER

 +2        SET U="^"

 +3        NEW %

           FOR %=1:1:$LENGTH(APCLX)

               IF $EXTRACT(APCLX,%)?1L

                   SET APCLX=$EXTRACT(APCLX,0,%-1)_$CHAR($ASCII(APCLX,%)-32)_$EXTRACT(APCLX,%+1,999)

 +4        SET PAT=$PIECE(APCLX,U)

           SET X=$PIECE(APCLX,U,2)

 +5        IF X=""

               SET APCLER=6

 +6        QUIT

 +7       ;

SET       ;

 +1       ; Rosetta Stone for the text line is:

 +2       ; FILE;TYPE;LOOKUP GLOBAL;PCC GLOBAL;SCREEN;QMAN TERM FOR TAXONOMY;TABLE XREF;SAVED;SAVED;SYNONYM;SYNONYM;SYNONYM

 +3       ;F I=1:1 S:$T(LKUP+I)=""&('$D(HIT)) APCLER=5 Q:$D(APCLER)!($T(LKUP+I)="")  I $E($P($T(LKUP+I),";",3),1,$L(FILE))=FILE!($P($T(LKUP+I),";",12,99)[FILE) S:$D(HIT) APCLER=12 S HIT=I K APCLHIT

 +4        FOR I=1:1

               IF $TEXT(LKUP+I)=""&('$DATA(HIT))

                   SET APCLER=5

               IF $DATA(APCLER)!($TEXT(LKUP+I)="")

                   QUIT

               Begin DoDot:1

 +5                NEW APCLI

 +6                FOR APCLI=12:1:99

                       IF $PIECE($TEXT(LKUP+I),";",APCLI)=""!$DATA(APCLHIT)

                           QUIT

                       SET APCLTXT=$PIECE($TEXT(LKUP+I),";",APCLI)

                       IF $EXTRACT(APCLTXT,1,$LENGTH(FILE))=FILE

                           SET APCLHIT=""

                           QUIT

 +7                KILL APCLTXT

               End DoDot:1

               IF $EXTRACT($PIECE($TEXT(LKUP+I),";",3),1,$LENGTH(FILE))=FILE!$DATA(APCLHIT)

                   IF $DATA(HIT)

                       SET APCLER=12

                   SET HIT=I

                   KILL APCLHIT

 +8        IF $DATA(APCLER)

               GOTO X1

 +9        SET LINE=$PIECE($TEXT(LKUP+HIT),";",3,99)

 +10       IF $DATA(APCLINT)

               SET APCLFILE=$PIECE(LINE,";")

 +11       SET TYPE=$PIECE(LINE,";",2)

 +12       IF $DATA(APCLINT)

               SET APCLTYPE=TYPE

 +13       SET TABLE=$PIECE(LINE,";",3)

 +14       SET LKUP=$PIECE(LINE,";",4)

 +15       IF $DATA(APCLINT)

               SET APCLFILE=$PIECE(@LKUP@(0),U)

 +16       SET SCRN=$PIECE(LINE,";",5)

 +17       SET TAX=$PIECE(LINE,";",6)

 +18       IF TAX=""

               IF (VAL["["!(VAL="*"))

                   SET APCLER=3

                   GOTO X1

 +19       IF VAL="*"

               IF TAX]""

                   IF $DATA(APCLINT)

                       DO TAX

 +20       SET XREF=$PIECE(LINE,";",7)

X1         QUIT

 +1       ;

TAX       ; User may create a taxonomy if they choose

 +1        SET X=TAX

           SET DIC="^AMQQ(5,"

           SET DIC(0)="FM"

           SET DIC("S")="I $P(^(0),U,14)"

           DO ^DIC

           IF Y=-1

               SET APCLER=7

               GOTO X5

 +2        SET X=+Y

           DO EN1^AMQQTX

           IF '$DATA(^UTILITY("AMQQ TAX",$JOB))

               SET APCLER=11

               GOTO X5

 +3        IF $GET(AMQQTDFN)>0

               SET VAL="["_$PIECE(^ATXAX(AMQQTDFN,0),U)_"]"

 +4        IF $DATA(^UTILITY("AMQQ TAX",$JOB))

               Begin DoDot:1

 +5                SET T=$ORDER(^UTILITY("AMQQ TAX",$JOB,""))

 +6                FOR TX=0:0

                       SET TX=$ORDER(^UTILITY("AMQQ TAX",$JOB,T,TX))

                       IF 'TX

                           QUIT

                       SET ^TMP("APCLTAX",$JOB,TX)=""

 +7                KILL ^UTILITY("AMQQ TAX")

               End DoDot:1

 +8        KILL AMQQCCLS,AMQQCNAM,AMQQDF,AMQQQ,AMQQTAX,AMQQURGN,AMQQTDFN,AMQQQUIT,AMQQECHO,AMQQGTX,AMQQTAXT,AMQQTGBL

X5         QUIT

 +1       ;

LKUP      ; D=Demographic, VI="AA" xref doesn't include .01 ptr val, VV does, NV is non-"V" file,VISIT=VISIT file

 +1       ;;PURPOSE OF VISITS;VI;^ICD9;^AUPNVPOV;;DIAGNOSIS;BA;;;POV;DX;DIAGNOSIS

 +2       ;;DENTAL SERVICES;VI;^AUTTADA;^AUPNVDEN;;ADA CODE;BA;;;ADA CODE

 +3       ;;EXAMINATIONS;VV;^AUTTEXAM;^AUPNVXAM;;;B;;;EXAMS

 +4       ;;VISIT;VISIT;;^AUPNVSIT;;;B;;;VISITS

 +5       ;;MEDICATIONS;VI;^PSDRUG;^AUPNVMED;;RX;B;;;RX;MEDS

 +6       ;;LABS;VV;^LAB(60);^AUPNVLAB;;LAB TAX;B;;;LABORATORY;LAB TESTS

 +7       ;;MEASUREMENTS;VV;^AUTTMSR;^AUPNVMSR;;;B

 +8       ;;PROCEDURES;VI;^ICD0;^AUPNVPRC;;PROCEDURE (MEDICAL);BA;;;

 +9       ;;SKIN TESTS;VV;^AUTTSK;^AUPNVSK;;;B

 +10      ;;IMMUNIZATIONS;VV;^AUTTIMM;^AUPNVIMM;;;B

 +11      ;;DIAGNOSTIC PROCEDURE;VV;^AUTTDXPR;^AUPNVDXP;;;B

 +12      ;;RADIOLOGY;VV;^RAMIS(71);^AUPNVRAD;;;B;;;XRAY;FILMS;RADIOLOGY STUDIES

 +13      ;;EDUCATION;VI;^AUTTEDT;^AUPNVPED;;PATIENT ED TOPIC;B;;;PT EDUCATION;EDUCATION TOPICS;PATIENT ED

 +14      ;;ACTIVE PROBLEMS;NV;^ICD9;^AUPNPROB;I $P(@LKUP@(D,0),U,12)'="D",$P(@LKUP@(D,0),U,12)'="I";PROBLEM LIST DIAGNOSIS;BA

 +15      ;;PROBLEMS;NV;^ICD9;^AUPNPROB;I $P(@LKUP@(D,0),U,12)'="D";PROBLEM LIST DIAGNOSIS;BA

 +16      ;;INACTIVE PROBLEMS;NV;^ICD9;^AUPNPROB;I $P(@LKUP@(D,0),U,12)="I";PROBLEM LIST DIAGNOSIS;BA

 +17      ;;FAMILY HISTORY;NV;^ICD9;^AUPNFH;;DIAGNOSIS;BA

 +18      ;;PERSONAL HISTORY;NV;^ICD9;^AUPNPH;;DIAGNOSIS;BA

 +19      ;;HLTH STATUS;NV;^AUTTHF;^AUPNHF;;HEALTH FACTORS;B

 +20      ;;HEALTH FACTORS;VV;^AUTTHF;^AUPNVHF;;HEALTH FACTORS;B;;;HEALTH STATUS

APCLDF.m