APCLVL0.m

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