APCLDF1 ; IHS/CMI/LAB -IHS -PROCESS ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
PARSE ;- ENTRY POINT from APCLDF - Parse script
S DATE=$P(X,";",2),X=$P(X,";")
S COND=$P(X," ")
I COND="ALL"!(COND="LAST")!(COND="FIRST")
E I "INACTIVEPROBLEMSFAMILYPERSONALHISTORY"[$P($P(X," "),".") S X="ALL "_X,COND="ALL"
E S X="ALL "_X,COND="ALL"
I '$P(X," ",2) S X=$P(X," ")_$S(COND="ALL":" 9999999 ",1:" 1 ")_$P(X," ",2,15)
S NUM=$P(X," ",2)
S FILE=$P(X," ",3),FILE=$TR(FILE,"."," ")
S VAL=$P(X," ",4,15)
I DATE]"" D DATE
X3 Q
;
DATE ; Process dates
NEW YRLER
S BOOL=$P(DATE," "),BOOL=$S(BOOL="<>":"<>","BEFORELESS<"[BOOL:"<","BETWEENDURING"[BOOL:"<>","AFTERGREATERSINCE>"[BOOL:">","ON=EQUALS"[BOOL:"=",1:"")
I BOOL="" S APCLER=16 G X9
S DATE=$P(DATE," ",2,15)
I BOOL="<>" S STDATE=$P(DATE,"-"),EDATE=$P(DATE,"-",2) D I 1
. S X=STDATE K %DT D ^%DT S STDATE=Y I Y=-1 S YRLER=17 G X10
. I EDATE="",$E(STDATE,6,7)'="00" S APCLER=17 G X10
. I EDATE="" S EDATE=STDATE
. E S X=EDATE K %DT D ^%DT S EDATE=Y I Y=-1 S YRLER=17 G X10
. I $E(STDATE,6,7)="00"!($E(EDATE,6,7)="00") F X="STDATE","EDATE" D DATECHG
X10 . Q
E S X=DATE S:BOOL="=" %DT="X" D ^%DT K %DT S DATE=Y D I Y=-1 S APCLER=17
. I Y=-1 Q
. I $E(DATE,6,7)="00" S X="DATE" D DATECHG
X9 Q
;
DATECHG ; Change dates to usuable form if user just enters date with year
; or month and year only
I X="STDATE" D G X11
. S STDATE=$S($E(STDATE,4,5)="00":$E(STDATE,1,3)_"0101",1:$E(STDATE,1,5)_"01")
I X="EDATE" D G X11
. S EDATE=$S($E(EDATE,4,5)="00":$E(EDATE,1,3)_1231,1:$E(EDATE,1,5)_31)
E D
. I BOOL=">" S DATE=$S($E(DATE,4,5)="00":$E(DATE,1,3)_1231,1:$E(DATE,1,5)_31)
. E S DATE=$S($E(DATE,4,5)="00":$E(DATE,1,3)_"0101",1:$E(DATE,1,5)_"01")
X11 Q
;
PROCESS ; - ENTRY POINT from APCLDF - Get values and/or create tax vals
I TYPE="VISIT" D VISIT^APCLDF3 G X8
I VAL="*" D G X8
. S APCLTX=""
. I COND'="LAST" S VAL=0 F S VAL=$O(^TMP("APCLTAX",$J,VAL)) Q:'VAL D @(TYPE_"^APCLDF2") Q:'VAL D I 1
.. I '$D(APCLER) D RESULTS^APCLDF2
. E S VAL="" D @(TYPE_"^APCLDF2") D
.. I '$D(APCLER) D RESULTS^APCLDF2
I $E(VAL)'="[" D
. D @(TYPE_"^APCLDF2")
E D
. I TAX="LAB TAX" D LABTAX G X8
. S X=TAX,DIC="^AMQQ(5,",DIC(0)="FM",DIC("S")="I $P(^(0),U,14)" D ^DIC K DIC
. I Y=-1 S APCLER=7
. E D
.. S AMQQLINK=$P(^AMQQ(5,+Y,0),U,5),AMQQTAXT=$P(^(0),U,14),AMQQTGBL=U_$P($P(^(0),U,18),"("),APCLTX=""
.. S X=VAL,AMQQGTX="^TMP(""APCLTAX"","_$J_"," S:$D(APCLINT) AMQQECHO="" D EN1^AMQQGTX D
... I '$D(^TMP("APCLTAX",$J)) S APCLER=10 Q
... ;I COND'="LAST" D @(TYPE_"^APCLDF2") I 1
...I COND'="LAST" S VAL=0 F S VAL=$O(^TMP("APCLTAX",$J,VAL)) Q:'VAL D @(TYPE_"^APCLDF2") Q:'VAL D I 1
....I '$D(APCLER) D RESULTS^APCLDF2
... E S VAL="" D @(TYPE_"^APCLDF2")
.. I '$D(APCLER) D RESULTS^APCLDF2
X8 Q
;
LABTAX ;resolve lab taxonomy and store in ^TMP("APCLTAX",$J,lab ien,site/spec ien)=""
NEW LABTAX,X
S APCLTX=""
S X=$E(VAL,2,99999999),DIC="^ATXLAB(",DIC(0)="FM" D ^DIC K DIC
I Y=-1 S APCLER=7 Q
S LABTAX=+Y
S X=0 F S X=$O(^ATXLAB(LABTAX,21,X)) Q:X'=+X S ^TMP("APCLTAX",$J,$P(^ATXLAB(LABTAX,21,X,0),U))="",Y=0 F S Y=$O(^ATXLAB(LABTAX,21,X,11,Y)) Q:Y'=+Y D
.Q ;DON'T DO THIS SITE/SPECIMEN CHECK IHS/CMI/LAB
.S Z=$P(^ATXLAB(LABTAX,21,X,0),U),T=$P(^ATXLAB(LABTAX,21,X,11,Y,0),U)
.S ^TMP("APCLTAX",$J,Z,T)=""
.Q
I '$D(^TMP("APCLTAX",$J)) S APCLER=10 Q
I COND'="LAST" S VAL=0 F S VAL=$O(^TMP("APCLTAX",$J,VAL)) Q:'VAL D @(TYPE_"^APCLDF2") Q:'VAL D I 1
.I '$D(APCLER) D RESULTS^APCLDF2
E S VAL="" D @(TYPE_"^APCLDF2")
I '$D(APCLER) D RESULTS^APCLDF2
K LABTAX,X,Y,Z,T
D @(TYPE_"^APCLDF2") Q:'VAL I 1
Q
APCLDF1 ; IHS/CMI/LAB -IHS -PROCESS ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
PARSE ;- ENTRY POINT from APCLDF - Parse script
+1 SET DATE=$PIECE(X,";",2)
SET X=$PIECE(X,";")
+2 SET COND=$PIECE(X," ")
+3 IF COND="ALL"!(COND="LAST")!(COND="FIRST")
+4 IF '$TEST
IF "INACTIVEPROBLEMSFAMILYPERSONALHISTORY"[$PIECE($PIECE(X," "),".")
SET X="ALL "_X
SET COND="ALL"
+5 IF '$TEST
SET X="ALL "_X
SET COND="ALL"
+6 IF '$PIECE(X," ",2)
SET X=$PIECE(X," ")_$SELECT(COND="ALL":" 9999999 ",1:" 1 ")_$PIECE(X," ",2,15)
+7 SET NUM=$PIECE(X," ",2)
+8 SET FILE=$PIECE(X," ",3)
SET FILE=$TRANSLATE(FILE,"."," ")
+9 SET VAL=$PIECE(X," ",4,15)
+10 IF DATE]""
DO DATE
X3 QUIT
+1 ;
DATE ; Process dates
+1 NEW YRLER
+2 SET BOOL=$PIECE(DATE," ")
SET BOOL=$SELECT(BOOL="<>":"<>","BEFORELESS<"[BOOL:"<","BETWEENDURING"[BOOL:"<>","AFTERGREATERSINCE>"[BOOL:">","ON=EQUALS"[BOOL:"=",1:"")
+3 IF BOOL=""
SET APCLER=16
GOTO X9
+4 SET DATE=$PIECE(DATE," ",2,15)
+5 IF BOOL="<>"
SET STDATE=$PIECE(DATE,"-")
SET EDATE=$PIECE(DATE,"-",2)
Begin DoDot:1
+6 SET X=STDATE
KILL %DT
DO ^%DT
SET STDATE=Y
IF Y=-1
SET YRLER=17
GOTO X10
+7 IF EDATE=""
IF $EXTRACT(STDATE,6,7)'="00"
SET APCLER=17
GOTO X10
+8 IF EDATE=""
SET EDATE=STDATE
+9 IF '$TEST
SET X=EDATE
KILL %DT
DO ^%DT
SET EDATE=Y
IF Y=-1
SET YRLER=17
GOTO X10
+10 IF $EXTRACT(STDATE,6,7)="00"!($EXTRACT(EDATE,6,7)="00")
FOR X="STDATE","EDATE"
DO DATECHG
X10 QUIT
End DoDot:1
IF 1
+1 IF '$TEST
SET X=DATE
IF BOOL="="
SET %DT="X"
DO ^%DT
KILL %DT
SET DATE=Y
Begin DoDot:1
+2 IF Y=-1
QUIT
+3 IF $EXTRACT(DATE,6,7)="00"
SET X="DATE"
DO DATECHG
End DoDot:1
IF Y=-1
SET APCLER=17
X9 QUIT
+1 ;
DATECHG ; Change dates to usuable form if user just enters date with year
+1 ; or month and year only
+2 IF X="STDATE"
Begin DoDot:1
+3 SET STDATE=$SELECT($EXTRACT(STDATE,4,5)="00":$EXTRACT(STDATE,1,3)_"0101",1:$EXTRACT(STDATE,1,5)_"01")
End DoDot:1
GOTO X11
+4 IF X="EDATE"
Begin DoDot:1
+5 SET EDATE=$SELECT($EXTRACT(EDATE,4,5)="00":$EXTRACT(EDATE,1,3)_1231,1:$EXTRACT(EDATE,1,5)_31)
End DoDot:1
GOTO X11
+6 IF '$TEST
Begin DoDot:1
+7 IF BOOL=">"
SET DATE=$SELECT($EXTRACT(DATE,4,5)="00":$EXTRACT(DATE,1,3)_1231,1:$EXTRACT(DATE,1,5)_31)
+8 IF '$TEST
SET DATE=$SELECT($EXTRACT(DATE,4,5)="00":$EXTRACT(DATE,1,3)_"0101",1:$EXTRACT(DATE,1,5)_"01")
End DoDot:1
X11 QUIT
+1 ;
PROCESS ; - ENTRY POINT from APCLDF - Get values and/or create tax vals
+1 IF TYPE="VISIT"
DO VISIT^APCLDF3
GOTO X8
+2 IF VAL="*"
Begin DoDot:1
+3 SET APCLTX=""
+4 IF COND'="LAST"
SET VAL=0
FOR
SET VAL=$ORDER(^TMP("APCLTAX",$JOB,VAL))
IF 'VAL
QUIT
DO @(TYPE_"^APCLDF2")
IF 'VAL
QUIT
Begin DoDot:2
+5 IF '$DATA(APCLER)
DO RESULTS^APCLDF2
End DoDot:2
IF 1
+6 IF '$TEST
SET VAL=""
DO @(TYPE_"^APCLDF2")
Begin DoDot:2
+7 IF '$DATA(APCLER)
DO RESULTS^APCLDF2
End DoDot:2
End DoDot:1
GOTO X8
+8 IF $EXTRACT(VAL)'="["
Begin DoDot:1
+9 DO @(TYPE_"^APCLDF2")
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 IF TAX="LAB TAX"
DO LABTAX
GOTO X8
+12 SET X=TAX
SET DIC="^AMQQ(5,"
SET DIC(0)="FM"
SET DIC("S")="I $P(^(0),U,14)"
DO ^DIC
KILL DIC
+13 IF Y=-1
SET APCLER=7
+14 IF '$TEST
Begin DoDot:2
+15 SET AMQQLINK=$PIECE(^AMQQ(5,+Y,0),U,5)
SET AMQQTAXT=$PIECE(^(0),U,14)
SET AMQQTGBL=U_$PIECE($PIECE(^(0),U,18),"(")
SET APCLTX=""
+16 SET X=VAL
SET AMQQGTX="^TMP(""APCLTAX"","_$JOB_","
IF $DATA(APCLINT)
SET AMQQECHO=""
DO EN1^AMQQGTX
Begin DoDot:3
+17 IF '$DATA(^TMP("APCLTAX",$JOB))
SET APCLER=10
QUIT
+18 ;I COND'="LAST" D @(TYPE_"^APCLDF2") I 1
+19 IF COND'="LAST"
SET VAL=0
FOR
SET VAL=$ORDER(^TMP("APCLTAX",$JOB,VAL))
IF 'VAL
QUIT
DO @(TYPE_"^APCLDF2")
IF 'VAL
QUIT
Begin DoDot:4
+20 IF '$DATA(APCLER)
DO RESULTS^APCLDF2
End DoDot:4
IF 1
+21 IF '$TEST
SET VAL=""
DO @(TYPE_"^APCLDF2")
End DoDot:3
+22 IF '$DATA(APCLER)
DO RESULTS^APCLDF2
End DoDot:2
End DoDot:1
X8 QUIT
+1 ;
LABTAX ;resolve lab taxonomy and store in ^TMP("APCLTAX",$J,lab ien,site/spec ien)=""
+1 NEW LABTAX,X
+2 SET APCLTX=""
+3 SET X=$EXTRACT(VAL,2,99999999)
SET DIC="^ATXLAB("
SET DIC(0)="FM"
DO ^DIC
KILL DIC
+4 IF Y=-1
SET APCLER=7
QUIT
+5 SET LABTAX=+Y
+6 SET X=0
FOR
SET X=$ORDER(^ATXLAB(LABTAX,21,X))
IF X'=+X
QUIT
SET ^TMP("APCLTAX",$JOB,$PIECE(^ATXLAB(LABTAX,21,X,0),U))=""
SET Y=0
FOR
SET Y=$ORDER(^ATXLAB(LABTAX,21,X,11,Y))
IF Y'=+Y
QUIT
Begin DoDot:1
+7 ;DON'T DO THIS SITE/SPECIMEN CHECK IHS/CMI/LAB
QUIT
+8 SET Z=$PIECE(^ATXLAB(LABTAX,21,X,0),U)
SET T=$PIECE(^ATXLAB(LABTAX,21,X,11,Y,0),U)
+9 SET ^TMP("APCLTAX",$JOB,Z,T)=""
+10 QUIT
End DoDot:1
+11 IF '$DATA(^TMP("APCLTAX",$JOB))
SET APCLER=10
QUIT
+12 IF COND'="LAST"
SET VAL=0
FOR
SET VAL=$ORDER(^TMP("APCLTAX",$JOB,VAL))
IF 'VAL
QUIT
DO @(TYPE_"^APCLDF2")
IF 'VAL
QUIT
Begin DoDot:1
+13 IF '$DATA(APCLER)
DO RESULTS^APCLDF2
End DoDot:1
IF 1
+14 IF '$TEST
SET VAL=""
DO @(TYPE_"^APCLDF2")
+15 IF '$DATA(APCLER)
DO RESULTS^APCLDF2
+16 KILL LABTAX,X,Y,Z,T
+17 DO @(TYPE_"^APCLDF2")
IF 'VAL
QUIT
IF 1
+18 QUIT
