AMQQMGR4.m

AMQQMGR4 ; IHS/CMI/THL - OVERFLOW FROM AMQQMGR3 ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;-----

LHEAD ; ENTRY POINT FROM AMQQMGR3 ; GETS HEADER INFO

 I AMQQLSPX S AMQQLUNT=$P($G(^LAB(60,AMQQLDFN,1,AMQQLSPX,0)),U,7)

 E  S AMQQLUNT=""

 S AMQQLHN=$P($G(^LAB(60,AMQQLDFN,.1)),U)

 S AMQQLHL=$L(AMQQLHN)

 S AMQQLOUT=""

 I AMQQLHN'="" G LHT

 S N=99

 F I=1:1 S X=$P(AMQQLSTG,U,I) Q:X=""  I $L(X)<N S Y=X,N=$L(X)

 I N=99 Q

 S AMQQLHN=Y

 S AMQQLHL=N

LHT I AMQQLTYP=9 S %=$P(^LAB(60,AMQQLDFN,0),U,12),%=U_%_"0)",%=$P(@%,U,2),%=+$E(%,4,9) G LH1

 I AMQQLTYP=15 S %=8,AMQQLOUT="S X=$P(X,"" ""),X=$S(X="""":""??"",X=0:""Neg."",X=+X:(""1:""_X),1:X)" G LH1

 I AMQQLTYP=12 S AMQQLOUT="S X=$P(X,"" "") S:X'?1N X=""??"" S:X?1N X=X+1,X=$P(""Neg.;Trace;1+;2+;3+;4+"","";"",X)" G LH1

 I AMQQLTYP=11 S AMQQLOUT="S X=$S($E(X)=""P"",""Pos"",1:""Neg"")",%=4 G LH1

 I AMQQLTYP=6 S %=0,X=$P(^LAB(60,AMQQLDFN,0),U,12),X=U_X_"0)",X=$P(@X,U,3) D LOUT F I=1:1 S Y=$P(X,";",I) G:Y="" LH1 S Y=$P(Y,":",2),Y=$L(Y) I Y>% S %=Y

 I AMQQLTYP=2 S %=0,X=$P(^LAB(60,AMQQLDFN,0),U,12) Q:X=""  S X=U_X_"0)",X=$P($G(@X),U,5),%=+$P(X,"K:$L(X)>",2)

LH1 I (%+4)>AMQQLHL S AMQQLHL=(%+4)

 Q

 ;

LOUT S AMQQLOUT="N Y S Y="";"_X_""",X=$F(Y,("";""_X_"":"")),X=$E(Y,X,999),X=$P(X,"";"")"

 Q

 ;

CO ; ENTRY POINT FROM AMQQMGR3

 S %=^LAB(60,AMQQLDFN,0)

 S %=$P(%,U)

 S %=$P(%," (")

 S %=$P(%,"(")

 S AMQQLC=%

 Q:%=""

 S AMQQLCO=%

 D CO2

 I $D(AMQQLCOF) G COEXIT

 I $D(AMQQCONO) K AMQQCONO G COEXIT

 F AMQQLI=70:1:79 I $D(^LAB(60,AMQQLDFN,1,AMQQLI,0)) D CO1

COEXIT K AMQQLC,AMQQLCO,AMQQLI

 Q

 ;

CO1 S %=$P("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(AMQQLI-69)),AMQQLCO=AMQQLC_","_%

CO2 S %=$O(^AMQQ(5,"C",AMQQLCO,""))

 Q:'%

 S DA(1)=%

 S X=AMQQLDFN

 S DIC="^AMQQ(5,"_DA(1)_",4.1,"

 S DIC(0)="L"

 I '$D(^AMQQ(5,DA(1),4.1,0)) S ^(0)="^9009075.02PA^^"

 D ^DIC

 K DIC

 I Y'=-1 S AMQQLCOF=""

 W !,$P(^LAB(60,AMQQLDFN,0),U)," added as a companion test of ",AMQQLCO

 Q

 ;

TOP ; ENTRY POINT ; GETS TOP 40 LAB TESTS

 D CHECK

 S I=$P(^AUPNVLAB(0),U,4)\500

 S G="^UTILITY(""AMQQ"",$J,""LU"")"

 S Z=""

 K @G

 F X=0:0 S X=$O(^AUPNVLAB(X)) Q:'X  S Y=+^(X,0),%=$G(@G@(1,Y))+1,^(Y)=%,X=X+I W:X#2 "."

 F X=0:0 S X=$O(@G@(1,X)) Q:'X  S Y=^(X),@G@(2,(10000-Y),X)="" W:X#2 "."

 W !!!,?15,"*****  TOP 40 LAB TESTS  *****",!!!

 S I=0

 F X=0:0 S X=$O(@G@(2,X)) Q:'X  F Y=0:0 S Y=$O(@G@(2,X,Y)) Q:'Y  S I=I+1 W:I#2 ! W:'(I#2) ?40 W I,") ",$E($P(^LAB(60,Y,0),U),1,30)," [",(10000-X),"]" S Z=Z_Y_U I I=40 G TOP1

TOP1 S AMQQLUST=Z

 D STUFF

 K @G,X,Y,Z,I,%

 Q

 ;

GET ; ENTRY POINT FOR 1 AT A TIME LAB TESTS

 D CHECK

 S Z=""

 F  D  I Y=-1!($E(Y)=U) Q

 .I $L(Z)>235 S Y="" W !!,"I can't accept more new tests now.  If you want to add more, try again later",!! Q

 .S DIR(0)="PO^60:EMQ"

 .S DIR("A")="Lab test"

 .S DIR("?")="Enter the name of the test you want to add to the Q-Man metadictionary."

 .D ^DIR

 .K DIR

 .I +Y=175 D NEWGLU

 .I +Y=643 W "  <= It's already in there" Q

 .I $D(^AMQQ(5,1000+Y)) W "   <= It's already in there!" Q

 .I (U_Z)[(U_Y_U) W "   <= Already selected" Q

 .S Z=Z_Y_U

 S AMQQLUST=Z

 D STUFF

 Q

 ;

STUFF W !!!

 F AMQQLSN=1:1 S X=$P(AMQQLUST,U,AMQQLSN) Q:X=""  D EN1^AMQQMGR3

 K AMQQLUST,AMQQLSN,X,Y,Z

 Q

 ;

LIST ; - EP - FROM ^AMQQMGR

 W !!!

 F X=1000:0 S X=$O(^AMQQ(5,X)) Q:'X  S Y=^(X,0),Y=$P(Y,U) W Y,", "

 K X,Y

 Q

 ;

CHECK ;

 S Z=0

 S X=$P(^AUPNVLAB(0),U,3)-1000

 F I=1:1:1000  S X=$O(^AUPNVLAB(X)) Q:'X  I $P($G(^AUPNVLAB(X,11)),U,3) S Z=1 Q

 I Z

 W:'Z !!,"Specimen/site not entered into V LAB...Request cancelled",!!,*7 H 2

 K X,Z,I

 Q

 ;

NEWGLU S DA(1)=184

 S DIK="^AMQQ(5,"_DA(1)_",1,"

 F DA=0:0 S DA=$O(^AMQQ(5,184,1,DA)) Q:'DA  D ^DIK

 K DIK,DA

 Q

 ;

AMQQMGR4  ; IHS/CMI/THL - OVERFLOW FROM AMQQMGR3 ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;-----

LHEAD     ; ENTRY POINT FROM AMQQMGR3 ; GETS HEADER INFO

 +1        IF AMQQLSPX

               SET AMQQLUNT=$PIECE($GET(^LAB(60,AMQQLDFN,1,AMQQLSPX,0)),U,7)

 +2       IF '$TEST

               SET AMQQLUNT=""

 +3        SET AMQQLHN=$PIECE($GET(^LAB(60,AMQQLDFN,.1)),U)

 +4        SET AMQQLHL=$LENGTH(AMQQLHN)

 +5        SET AMQQLOUT=""

 +6        IF AMQQLHN'=""

               GOTO LHT

 +7        SET N=99

 +8        FOR I=1:1

               SET X=$PIECE(AMQQLSTG,U,I)

               IF X=""

                   QUIT 

               IF $LENGTH(X)<N

                   SET Y=X

                   SET N=$LENGTH(X)

 +9        IF N=99

               QUIT 

 +10       SET AMQQLHN=Y

 +11       SET AMQQLHL=N

LHT        IF AMQQLTYP=9

               SET %=$PIECE(^LAB(60,AMQQLDFN,0),U,12)

               SET %=U_%_"0)"

               SET %=$PIECE(@%,U,2)

               SET %=+$EXTRACT(%,4,9)

               GOTO LH1

 +1        IF AMQQLTYP=15

               SET %=8

               SET AMQQLOUT="S X=$P(X,"" ""),X=$S(X="""":""??"",X=0:""Neg."",X=+X:(""1:""_X),1:X)"

               GOTO LH1

 +2        IF AMQQLTYP=12

               SET AMQQLOUT="S X=$P(X,"" "") S:X'?1N X=""??"" S:X?1N X=X+1,X=$P(""Neg.;Trace;1+;2+;3+;4+"","";"",X)"

               GOTO LH1

 +3        IF AMQQLTYP=11

               SET AMQQLOUT="S X=$S($E(X)=""P"",""Pos"",1:""Neg"")"

               SET %=4

               GOTO LH1

 +4        IF AMQQLTYP=6

               SET %=0

               SET X=$PIECE(^LAB(60,AMQQLDFN,0),U,12)

               SET X=U_X_"0)"

               SET X=$PIECE(@X,U,3)

               DO LOUT

               FOR I=1:1

                   SET Y=$PIECE(X,";",I)

                   IF Y=""

                       GOTO LH1

                   SET Y=$PIECE(Y,":",2)

                   SET Y=$LENGTH(Y)

                   IF Y>%

                       SET %=Y

 +5        IF AMQQLTYP=2

               SET %=0

               SET X=$PIECE(^LAB(60,AMQQLDFN,0),U,12)

               IF X=""

                   QUIT 

               SET X=U_X_"0)"

               SET X=$PIECE($GET(@X),U,5)

               SET %=+$PIECE(X,"K:$L(X)>",2)

LH1        IF (%+4)>AMQQLHL

               SET AMQQLHL=(%+4)

 +1        QUIT 

 +2       ;

LOUT       SET AMQQLOUT="N Y S Y="";"_X_""",X=$F(Y,("";""_X_"":"")),X=$E(Y,X,999),X=$P(X,"";"")"

 +1        QUIT 

 +2       ;

CO        ; ENTRY POINT FROM AMQQMGR3

 +1        SET %=^LAB(60,AMQQLDFN,0)

 +2        SET %=$PIECE(%,U)

 +3        SET %=$PIECE(%," (")

 +4        SET %=$PIECE(%,"(")

 +5        SET AMQQLC=%

 +6        IF %=""

               QUIT 

 +7        SET AMQQLCO=%

 +8        DO CO2

 +9        IF $DATA(AMQQLCOF)

               GOTO COEXIT

 +10       IF $DATA(AMQQCONO)

               KILL AMQQCONO

               GOTO COEXIT

 +11       FOR AMQQLI=70:1:79

               IF $DATA(^LAB(60,AMQQLDFN,1,AMQQLI,0))

                   DO CO1

COEXIT     KILL AMQQLC,AMQQLCO,AMQQLI

 +1        QUIT 

 +2       ;

CO1        SET %=$PIECE("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(AMQQLI-69))

           SET AMQQLCO=AMQQLC_","_%

CO2        SET %=$ORDER(^AMQQ(5,"C",AMQQLCO,""))

 +1        IF '%

               QUIT 

 +2        SET DA(1)=%

 +3        SET X=AMQQLDFN

 +4        SET DIC="^AMQQ(5,"_DA(1)_",4.1,"

 +5        SET DIC(0)="L"

 +6        IF '$DATA(^AMQQ(5,DA(1),4.1,0))

               SET ^(0)="^9009075.02PA^^"

 +7        DO ^DIC

 +8        KILL DIC

 +9        IF Y'=-1

               SET AMQQLCOF=""

 +10       WRITE !,$PIECE(^LAB(60,AMQQLDFN,0),U)," added as a companion test of ",AMQQLCO

 +11       QUIT 

 +12      ;

TOP       ; ENTRY POINT ; GETS TOP 40 LAB TESTS

 +1        DO CHECK

 +2        SET I=$PIECE(^AUPNVLAB(0),U,4)\500

 +3        SET G="^UTILITY(""AMQQ"",$J,""LU"")"

 +4        SET Z=""

 +5        KILL @G

 +6        FOR X=0:0

               SET X=$ORDER(^AUPNVLAB(X))

               IF 'X

                   QUIT 

               SET Y=+^(X,0)

               SET %=$GET(@G@(1,Y))+1

               SET ^(Y)=%

               SET X=X+I

               IF X#2

                   WRITE "."

 +7        FOR X=0:0

               SET X=$ORDER(@G@(1,X))

               IF 'X

                   QUIT 

               SET Y=^(X)

               SET @G@(2,(10000-Y),X)=""

               IF X#2

                   WRITE "."

 +8        WRITE !!!,?15,"*****  TOP 40 LAB TESTS  *****",!!!

 +9        SET I=0

 +10       FOR X=0:0

               SET X=$ORDER(@G@(2,X))

               IF 'X

                   QUIT 

               FOR Y=0:0

                   SET Y=$ORDER(@G@(2,X,Y))

                   IF 'Y

                       QUIT 

                   SET I=I+1

                   IF I#2

                       WRITE !

                   IF '(I#2)

                       WRITE ?40

                   WRITE I,") ",$EXTRACT($PIECE(^LAB(60,Y,0),U),1,30)," [",(10000-X),"]"

                   SET Z=Z_Y_U

                   IF I=40

                       GOTO TOP1

TOP1       SET AMQQLUST=Z

 +1        DO STUFF

 +2        KILL @G,X,Y,Z,I,%

 +3        QUIT 

 +4       ;

GET       ; ENTRY POINT FOR 1 AT A TIME LAB TESTS

 +1        DO CHECK

 +2        SET Z=""

 +3        FOR 

               Begin DoDot:1

 +4                IF $LENGTH(Z)>235

                       SET Y=""

                       WRITE !!,"I can't accept more new tests now.  If you want to add more, try again later",!!

                       QUIT 

 +5                SET DIR(0)="PO^60:EMQ"

 +6                SET DIR("A")="Lab test"

 +7                SET DIR("?")="Enter the name of the test you want to add to the Q-Man metadictionary."

 +8                DO ^DIR

 +9                KILL DIR

 +10               IF +Y=175

                       DO NEWGLU

 +11               IF +Y=643

                       WRITE "  <= It's already in there"

                       QUIT 

 +12               IF $DATA(^AMQQ(5,1000+Y))

                       WRITE "   <= It's already in there!"

                       QUIT 

 +13               IF (U_Z)[(U_Y_U)

                       WRITE "   <= Already selected"

                       QUIT 

 +14               SET Z=Z_Y_U

               End DoDot:1

               IF Y=-1!($EXTRACT(Y)=U)

                   QUIT 

 +15       SET AMQQLUST=Z

 +16       DO STUFF

 +17       QUIT 

 +18      ;

STUFF      WRITE !!!

 +1        FOR AMQQLSN=1:1

               SET X=$PIECE(AMQQLUST,U,AMQQLSN)

               IF X=""

                   QUIT 

               DO EN1^AMQQMGR3

 +2        KILL AMQQLUST,AMQQLSN,X,Y,Z

 +3        QUIT 

 +4       ;

LIST      ; - EP - FROM ^AMQQMGR

 +1        WRITE !!!

 +2        FOR X=1000:0

               SET X=$ORDER(^AMQQ(5,X))

               IF 'X

                   QUIT 

               SET Y=^(X,0)

               SET Y=$PIECE(Y,U)

               WRITE Y,", "

 +3        KILL X,Y

 +4        QUIT 

 +5       ;

CHECK     ;

 +1        SET Z=0

 +2        SET X=$PIECE(^AUPNVLAB(0),U,3)-1000

 +3        FOR I=1:1:1000

               SET X=$ORDER(^AUPNVLAB(X))

               IF 'X

                   QUIT 

               IF $PIECE($GET(^AUPNVLAB(X,11)),U,3)

                   SET Z=1

                   QUIT 

 +4        IF Z

 +5        IF 'Z

               WRITE !!,"Specimen/site not entered into V LAB...Request cancelled",!!,*7

           HANG 2

 +6        KILL X,Z,I

 +7        QUIT 

 +8       ;

NEWGLU     SET DA(1)=184

 +1        SET DIK="^AMQQ(5,"_DA(1)_",1,"

 +2        FOR DA=0:0

               SET DA=$ORDER(^AMQQ(5,184,1,DA))

               IF 'DA

                   QUIT 

               DO ^DIK

 +3        KILL DIK,DA

 +4        QUIT 

 +5       ;