APCLVL0 ; IHS/CMI/LAB - SCREEN LOGIC ;
;;2.0;IHS PCC SUITE;**2,17**;MAY 14, 2009;Build 18
;
;
Q ;EP
K AMQQTAXN
K ^XTMP("APCLVL",$J,"QMAN"),^UTILITY("AMQQ TAX",$J),^UTILITY("AMQQ DRUG CLASS",$J)
K DIC,X,Y,DD S X=$P(^APCLVSTS(APCLCRIT,0),U,3),DIC="^AMQQ(5,",DIC(0)="EQXM",D="B",DIC("S")="I $P(^(0),U,14)" D MIX^DIC1 K DIC,DA,DINUM,DICR I Y=-1 W "OOPS - QMAN NOT CURRENT - QUITTING" Q
S APCLQMAN=+Y
I $P(^APCLVSTS(APCLCRIT,0),U)["Cause of Injury" S AMQQSQNM="CAUSE OF INJURY (PRIMARY)" ;FIX FOR CAUSE OF INJURY
;I $P(^APCLVSTS(APCLCRIT,0),U)="Cause of Injury" S AMQQSQNM="CAUSE OF INJURY"
D PEP^AMQQGTX0(APCLQMAN,"^XTMP(""APCLVL"",$J,""QMAN"",")
I '$D(^XTMP("APCLVL",$J,"QMAN")) W !!,$C(7),"** No ",$P(^APCLVSTS(APCLCRIT,0),U)," selected, all will be included." Q
I $D(^XTMP("APCLVL",$J,"QMAN","*")) K ^XTMP("APCLVL",$J,"QMAN") W !!,"*** All items selected, if you want all then do not select this item." Q
K APCLBQC1 I $G(APCLBQC),$P($G(^APCLVSTS(APCLCRIT,90182)),U,5)=1,$G(AMQQTAXN)]"" S APCLBQC1="" D TAXV Q:APCLBQC1=""
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
I $G(APCLBQC1)="T" S ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)="["_AMQQTAXN,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B","["_$P(AMQQTAXN,U),1)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1" G Q1
S X="",Y=0 F S X=$O(^XTMP("APCLVL",$J,"QMAN",X)) Q:X="" S Y=Y+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,Y)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
Q1 K X,Y,Z,APCLQMAN,V,AMQQSQNM,AMQQTAXN
K ^XTMP("APCLVL",$J,"QMAN")
Q
R ;EP
S DIR(0)=$P(^APCLVSTS(APCLCRIT,0),U,4)_"O",DIR("A")="ENTER "_$P(^(0),U) D ^DIR K DIR S:$D(DUOUT) DIRUT=1
Q:$D(DIRUT)
Q:Y=-1
I Y="" Q
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S APCLCNT=APCLCNT+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)=$P(Y,U),^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",$P(Y,U),APCLCNT)="",^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_APCLCNT_"^"_APCLCNT
G R
Q
D ;DATE RANGE
BD ;get beginning date
W ! S DIR(0)="D^::EP",DIR("A")="Enter beginning "_APCLTEXT_" for Search" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) Q
S APCLBDAT=Y
ED ;get ending date
W ! S DIR(0)="D^"_APCLBDAT_"::EP",DIR("A")="Enter ending "_APCLTEXT_" for Search" S Y=APCLBDAT D DD^%DT S DIR("B")=Y,Y="" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I $D(DIRUT) G BD
S APCLEDAT=Y
S X1=APCLBDAT,X2=-1 D C^%DTC S APCLSDAT=X
;
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S APCLCNT=0,^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1" S APCLCNT=APCLCNT+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=APCLBDAT_U_APCLEDAT,^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",APCLBDAT,APCLCNT)=""
Q
N ;
D N^APCLVL01
Q
F ;FREE TEXT RANGE
K ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
S DIR(0)="FO^1:40",DIR("A")="Enter a Range of Characters for Search (e.g. A:B) " D ^DIR K DIR S:$D(DUOUT) DIRUT=1
I Y="" W !!,"No range entered. All ",APCLTEXT," will be included." Q
I $D(^APCLVSTS(APCLCRIT,21)) S X=Y X ^(21) I '$D(X),$D(^APCLVSTS(APCLCRIT,22)) W !! X ^(22) G F ;if input tx exists and fails G N
I '$D(^APCLVSTS(APCLCRIT,21)),Y'?1.ANP1":"1.ANP W !!,$C(7),$C(7),"Enter an free text range in the format AAA:AAA. E.g. 94-01:94-200,CA:CZ, A:Z." G F
S ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT,^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
S APCLCNT=0,^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1" S APCLCNT=APCLCNT+1,^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=$P(X,":")_U_$P(X,":",2),^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",$P(X,":"),APCLCNT)=""
Q
J ;
D J^APCLVL01
Q
C ;EP
D C^APCLVL01
Q
Y ;
D Y^APCLVL01
Q
TAXV ;for query cloning
W !!,"You entered a taxonomy name for this item. ["_$P(AMQQTAXN,U)_"]"
W !,"You have the option of sending the name of the taxonomy to each site and have"
W !,"the taxonomy resolved at the site OR to send the individual coded values"
W !,"for this taxonomy.",!
S DIR(0)="S^T:Taxonomy Name (this taxonomy must reside at each site);V:Values in this Taxonomy",DIR("A")="Which do you wish to send for this item",DIR("B")="T" KILL DA D ^DIR KILL DIR
I $D(DIRUT) W !,"exiting......start over.." Q
S APCLBQC1=Y
Q
S ;
D S^APCLVL01
Q
APCLVL0 ; IHS/CMI/LAB - SCREEN LOGIC ;
+1 ;;2.0;IHS PCC SUITE;**2,17**;MAY 14, 2009;Build 18
+2 ;
+3 ;
Q ;EP
+1 KILL AMQQTAXN
+2 KILL ^XTMP("APCLVL",$JOB,"QMAN"),^UTILITY("AMQQ TAX",$JOB),^UTILITY("AMQQ DRUG CLASS",$JOB)
+3 KILL DIC,X,Y,DD
SET X=$PIECE(^APCLVSTS(APCLCRIT,0),U,3)
SET DIC="^AMQQ(5,"
SET DIC(0)="EQXM"
SET D="B"
SET DIC("S")="I $P(^(0),U,14)"
DO MIX^DIC1
KILL DIC,DA,DINUM,DICR
IF Y=-1
WRITE "OOPS - QMAN NOT CURRENT - QUITTING"
QUIT
+4 SET APCLQMAN=+Y
+5 ;FIX FOR CAUSE OF INJURY
IF $PIECE(^APCLVSTS(APCLCRIT,0),U)["Cause of Injury"
SET AMQQSQNM="CAUSE OF INJURY (PRIMARY)"
+6 ;I $P(^APCLVSTS(APCLCRIT,0),U)="Cause of Injury" S AMQQSQNM="CAUSE OF INJURY"
+7 DO PEP^AMQQGTX0(APCLQMAN,"^XTMP(""APCLVL"",$J,""QMAN"",")
+8 IF '$DATA(^XTMP("APCLVL",$JOB,"QMAN"))
WRITE !!,$CHAR(7),"** No ",$PIECE(^APCLVSTS(APCLCRIT,0),U)," selected, all will be included."
QUIT
+9 IF $DATA(^XTMP("APCLVL",$JOB,"QMAN","*"))
KILL ^XTMP("APCLVL",$JOB,"QMAN")
WRITE !!,"*** All items selected, if you want all then do not select this item."
QUIT
+10 KILL APCLBQC1
IF $GET(APCLBQC)
IF $PIECE($GET(^APCLVSTS(APCLCRIT,90182)),U,5)=1
IF $GET(AMQQTAXN)]""
SET APCLBQC1=""
DO TAXV
IF APCLBQC1=""
QUIT
+11 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+12 IF $GET(APCLBQC1)="T"
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)="["_AMQQTAXN
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B","["_$PIECE(AMQQTAXN,U),1)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^1^1"
GOTO Q1
+13 SET X=""
SET Y=0
FOR
SET X=$ORDER(^XTMP("APCLVL",$JOB,"QMAN",X))
IF X=""
QUIT
SET Y=Y+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,Y,0)=X
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",X,Y)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_Y_"^"_Y
Q1 KILL X,Y,Z,APCLQMAN,V,AMQQSQNM,AMQQTAXN
+1 KILL ^XTMP("APCLVL",$JOB,"QMAN")
+2 QUIT
R ;EP
+1 SET DIR(0)=$PIECE(^APCLVSTS(APCLCRIT,0),U,4)_"O"
SET DIR("A")="ENTER "_$PIECE(^(0),U)
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 IF Y=-1
QUIT
+4 IF Y=""
QUIT
+5 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+6 SET APCLCNT=APCLCNT+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)=$PIECE(Y,U)
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",$PIECE(Y,U),APCLCNT)=""
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,0)="^9001003.8110101A^"_APCLCNT_"^"_APCLCNT
+7 GOTO R
+8 QUIT
D ;DATE RANGE
BD ;get beginning date
+1 WRITE !
SET DIR(0)="D^::EP"
SET DIR("A")="Enter beginning "_APCLTEXT_" for Search"
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
QUIT
+3 SET APCLBDAT=Y
ED ;get ending date
+1 WRITE !
SET DIR(0)="D^"_APCLBDAT_"::EP"
SET DIR("A")="Enter ending "_APCLTEXT_" for Search"
SET Y=APCLBDAT
DO DD^%DT
SET DIR("B")=Y
SET Y=""
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+2 IF $DATA(DIRUT)
GOTO BD
+3 SET APCLEDAT=Y
+4 SET X1=APCLBDAT
SET X2=-1
DO C^%DTC
SET APCLSDAT=X
+5 ;
+6 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+7 SET APCLCNT=0
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
SET APCLCNT=APCLCNT+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=APCLBDAT_U_APCLEDAT
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",APCLBDAT,APCLCNT)=""
+8 QUIT
N ;
+1 DO N^APCLVL01
+2 QUIT
F ;FREE TEXT RANGE
+1 KILL ^APCLVRPT(APCLRPT,11,APCLCRIT),^APCLVRPT(APCLRPT,11,"B",APCLCRIT)
+2 SET DIR(0)="FO^1:40"
SET DIR("A")="Enter a Range of Characters for Search (e.g. A:B) "
DO ^DIR
KILL DIR
IF $DATA(DUOUT)
SET DIRUT=1
+3 IF Y=""
WRITE !!,"No range entered. All ",APCLTEXT," will be included."
QUIT
+4 ;if input tx exists and fails G N
IF $DATA(^APCLVSTS(APCLCRIT,21))
SET X=Y
XECUTE ^(21)
IF '$DATA(X)
IF $DATA(^APCLVSTS(APCLCRIT,22))
WRITE !!
XECUTE ^(22)
GOTO F
+5 IF '$DATA(^APCLVSTS(APCLCRIT,21))
IF Y'?1.ANP1":"1.ANP
WRITE !!,$CHAR(7),$CHAR(7),"Enter an free text range in the format AAA:AAA. E.g. 94-01:94-200,CA:CZ, A:Z."
GOTO F
+6 SET ^APCLVRPT(APCLRPT,11,APCLCRIT,0)=APCLCRIT
SET ^APCLVRPT(APCLRPT,11,"B",APCLCRIT,APCLCRIT)=""
+7 SET APCLCNT=0
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,APCLCNT,0)="^9001003.8110101A^1^1"
SET APCLCNT=APCLCNT+1
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,1,0)=$PIECE(X,":")_U_$PIECE(X,":",2)
SET ^APCLVRPT(APCLRPT,11,APCLCRIT,11,"B",$PIECE(X,":"),APCLCNT)=""
+8 QUIT
J ;
+1 DO J^APCLVL01
+2 QUIT
C ;EP
+1 DO C^APCLVL01
+2 QUIT
Y ;
+1 DO Y^APCLVL01
+2 QUIT
TAXV ;for query cloning
+1 WRITE !!,"You entered a taxonomy name for this item. ["_$PIECE(AMQQTAXN,U)_"]"
+2 WRITE !,"You have the option of sending the name of the taxonomy to each site and have"
+3 WRITE !,"the taxonomy resolved at the site OR to send the individual coded values"
+4 WRITE !,"for this taxonomy.",!
+5 SET DIR(0)="S^T:Taxonomy Name (this taxonomy must reside at each site);V:Values in this Taxonomy"
SET DIR("A")="Which do you wish to send for this item"
SET DIR("B")="T"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
WRITE !,"exiting......start over.."
QUIT
+7 SET APCLBQC1=Y
+8 QUIT
S ;
+1 DO S^APCLVL01
+2 QUIT
