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
Q
;
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
