AMQQMGR7 ; IHS/CMI/THL - LAB STARTUP OVERFLOW ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;-----
SAVE(AMQQLDFN) ;EP;
I '$D(^LAB(60,AMQQLDFN)) Q
S %=$P(^LAB(60,AMQQLDFN,0),U,12)
I %="" Q
I $P($G(@(U_%_"0)")),U,5)="" Q
I $P(^LAB(60,AMQQLDFN,0),U,3)="N" Q
N AMQQLSS,AMQQLSSX,AMQQLSSN,X,Y,AMQQLAKA,AMQQLAKN,AMQQLSPX,AMQQLOFF,AMQQLSPC,AMQQLDS,AMQQLTYP
S AMQQLAKA=$P(^LAB(60,AMQQLDFN,0),U)
S AMQQLAKN=1
S X=0
F S X=$O(^LAB(60,AMQQLDFN,5,X)) Q:'X S Y=^(X,0),AMQQLAKA=AMQQLAKA_U_Y,AMQQLAKN=AMQQLAKN+1 ; GET AKAs
S X=AMQQLDFN
S AMQQLSS=""
S AMQQLSSX=""
S AMQQLSSN=0
F S X=$O(@TMP@(X)) Q:'X!(X>(AMQQLDFN+.99999)) D ; GET SITE/SPECIMINES
.S Y=$G(@TMP@("C",X))
.I 'Y Q
.I Y'=44,'$D(^LAB(60,AMQQLDFN,1,Y,0)) Q
.I Y'=44,((Y<70)!(Y>79)) Q
.I Y=44 S AMQQLSS=AMQQLSS_"UNKNOWN SITE/SPECIMEN"_U
.E S AMQQLSS=AMQQLSS_$P("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(Y-69))_U
.S AMQQLSSN=AMQQLSSN+1
.S AMQQLSSX=AMQQLSSX_Y_U
I 'AMQQLSSN G LEXIT
S AMQQLDS=0
S %=$P(^LAB(60,AMQQLDFN,0),U,12)
I %'="" S %=U_%_"0)",AMQQLDS=($P($G(@%),U,3)[";Trace:")
I AMQQLAKA["(HGB)" S AMQQLSS="BLOOD",AMQQLSSN=1
I AMQQLSSN<2 D G LEXIT
.S AMQQLSPX=$P(AMQQLSSX,U)
.S AMQQLOFF=+("."_$P(AMQQLSSX,U))
.D LN1
.D LTYPE
.D LHEAD^AMQQMGR4
.D LSET
F AMQQLI=1:1:AMQQLSSN D
.S AMQQLSPC=$P(AMQQLSS,U,AMQQLI)
.S AMQQLSPX=$P(AMQQLSSX,U,AMQQLI)
.S AMQQLOFF=+("."_AMQQLSPX)
.D LN2
.D LTYPE
.D LHEAD^AMQQMGR4
.D LSET
LEXIT K AMQQLSTG,AMQQLSS,AMQQLSSN,AMQQLAKA,AMQQLAKN,AMQQLHL,AMQQLHN,AMQQLHL,AMQQLOUT,AMQQLUNT,I,%,N,X,Y,Z,AMQQLOFF,AMQQLI
Q
;
LN1 S I=0,AMQQLSTG=""
F X=1:1 S Y=$P(AMQQLAKA,U,X) Q:Y="" D
.S I=I+1
.S $P(AMQQLSTG,U,I)=Y_$S((AMQQLDS&(AMQQLSS["URINE")):",DIPSTICK",1:"")
.I $E(Y,U,6)="URINE " D
..S %=$S(AMQQLDS:"DIPSTICK ",1:"")
..S I=I+1
..S $P(AMQQLSTG,U,I)=$E(Y,7,99)_","_%_"URINE"
..S I=I+1
..S $P(AMQQLSTG,U,I)="UR "_$E(Y,7,99)_$S(%'="":(","_%),1:"")
Q
;
LN2 S AMQQLSTG=""
S I=0
F Y=1:1 S Z=$P(AMQQLAKA,U,Y) Q:Z="" D
.S I=I+1
.S $P(AMQQLSTG,U,I)=AMQQLSPC_" "_Z
.S I=I+1
.S $P(AMQQLSTG,U,I)=Z_$S(Z[",":" ",1:",")_AMQQLSPC
.I AMQQLSPC="URINE" S I=I+1,$P(AMQQLSTG,U,I)="UR "_Z
Q
;
LTYPE I $O(^LAB(60,AMQQLDFN,200,0)) S AMQQLTYP="" Q
S %=$P(^LAB(60,AMQQLDFN,0),U,12)
I %="" G TF
S %=U_%_"0)"
I '$D(@%) G TF
I $P(@%,U,3)[";Trace:" S AMQQLTYP=12 Q
I ($P(@%,U,5,6)["Q9=")+($G(^(3))[" NUMBER ") S AMQQLTYP=9 Q
I $P(@%,U,5,6)[" NUMBER " S AMQQLTYP=9 Q
I $P(@%,U,3)[";Pos.:" S AMQQLTYP=11 Q
I $G(AMQQLSTG)["TITRE"!($P(@%,U,5)["""""titre""""")!($G(^(3))["1:") S AMQQLTYP=15 Q
I $P(@%,U,2)="S" S AMQQLTYP=6 Q
TF S AMQQLTYP=2
Q
;
LSET ;
I $D(AMQQLTRM) K AMQQLTRM Q
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
N DIC,DIE,DR,DA,D,X,Y,AMQQI
S (DIC,DIE)="^AMQQ(5,"
S DIC(0)="L"
S X=$P(AMQQLSTG,U)
S DINUM=AMQQLDFN+1000+AMQQLOFF
Q:$D(^AMQQ(5,DINUM))
D FILE^DICN
K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
I Y=-1 Q
S DA(1)=+Y
S DIC=DIE_DA(1)_",1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(9009075,.02,0),U,2)
F AMQQI=1:1 S X=$P(AMQQLSTG,U,AMQQI) Q:X="" D ^DIC
S DR="1////P;1.1////V;3////3;4////9;19////C;20////M;41////"_AMQQLTYP_";42////"_AMQQLDFN_";43////"_AMQQLSPX_";44////"_AMQQLHN_";45////"_AMQQLHL_";46////"_AMQQLUNT
I AMQQLOUT'="" S DR=DR_";47////^S X=AMQQLOUT"
D ^DIE
K DR,DIC,DIE,DQ,DR,DI,D1,D0
W "."
Q
;
RESCO ; RESTORE COMPANION LAB TESTS
N DIC,X,Y,%,DA,AMQQLAB,AMQQCO
I '$D(^UTILITY("AMQQ LC",$J)) Q
S DIC(0)="L"
S DIC("P")=$P($G(^DD(9009075,40,0)),U,2)
S AMQQLAB=0
F S AMQQLAB=$O(^UTILITY("AMQQ LC",$J,AMQQLAB)) Q:'AMQQLAB S AMQQCO=0 F S AMQQCO=$O(^UTILITY("AMQQ LC",$J,AMQQLAB,AMQQCO)) Q:'AMQQCO D ADD W "."
K ^UTILITY("AMQQ LC",$J)
Q
;
COMP ; ADD COMPANION LAB TESTS
W !,"Want to define new 'COMPANION' lab tests"
S %=2
D YN^DICN
I %=2 Q
S DIC("A")="Enter primary test name (the one that will have companions): "
PASK S DIC="^AMQQ(5,"
S DIC(0)="AEQM"
S DIC("S")="I Y>999"
D ^DIC
K DIC
I Y=-1 Q
S AMQQLAB=+Y
D CLOOK
S DIC("A")="Enter a companion test name: "
CASK S DIC="^LAB(60,",DIC(0)="AEQM"
D ^DIC
K DIC
I Y=-1 G LOOP
S AMQQCO=+Y
D CADD
S DIC("A")="Enter another companion test: "
G CASK
LOOP W !
S DIC("A")="Enter another primary test name: "
G PASK
;
CADD N %,%Y,DIC,X,Y,DA
W !,"Are you sure you want to add this companion test"
S %=1
D YN^DICN
I %'=1 Q
S DIC(0)="L"
S DIC("P")=$P($G(^DD(9009075,40,0)),U,2)
ADD ;
I '$D(^AMQQ(5,AMQQLAB,0)) Q
S DA(1)=AMQQLAB
S DIC="^AMQQ(5,"_DA(1)_",4.1,"
S X="`"_AMQQCO
D ^DIC
Q
;
CLOOK ;
N X,Y
I '$O(^AMQQ(5,"LC",AMQQLAB,0)) Q
W !!,"The following tests are already companions to ",$P($G(^AMQQ(5,AMQQLAB,0)),U)," =>",!
S X=0
F S X=$O(^AMQQ(5,"LC",AMQQLAB,X)) Q:'X D
.S Y=$P($G(^LAB(60,+X,0)),U)
.W:$L(Y) !?2,Y
W !!
Q
AMQQMGR7 ; IHS/CMI/THL - LAB STARTUP OVERFLOW ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;-----
SAVE(AMQQLDFN) ;EP;
+1 IF '$DATA(^LAB(60,AMQQLDFN))
QUIT
+2 SET %=$PIECE(^LAB(60,AMQQLDFN,0),U,12)
+3 IF %=""
QUIT
+4 IF $PIECE($GET(@(U_%_"0)")),U,5)=""
QUIT
+5 IF $PIECE(^LAB(60,AMQQLDFN,0),U,3)="N"
QUIT
+6 NEW AMQQLSS,AMQQLSSX,AMQQLSSN,X,Y,AMQQLAKA,AMQQLAKN,AMQQLSPX,AMQQLOFF,AMQQLSPC,AMQQLDS,AMQQLTYP
+7 SET AMQQLAKA=$PIECE(^LAB(60,AMQQLDFN,0),U)
+8 SET AMQQLAKN=1
+9 SET X=0
+10 ; GET AKAs
FOR
SET X=$ORDER(^LAB(60,AMQQLDFN,5,X))
IF 'X
QUIT
SET Y=^(X,0)
SET AMQQLAKA=AMQQLAKA_U_Y
SET AMQQLAKN=AMQQLAKN+1
+11 SET X=AMQQLDFN
+12 SET AMQQLSS=""
+13 SET AMQQLSSX=""
+14 SET AMQQLSSN=0
+15 ; GET SITE/SPECIMINES
FOR
SET X=$ORDER(@TMP@(X))
IF 'X!(X>(AMQQLDFN+.99999))
QUIT
Begin DoDot:1
+16 SET Y=$GET(@TMP@("C",X))
+17 IF 'Y
QUIT
+18 IF Y'=44
IF '$DATA(^LAB(60,AMQQLDFN,1,Y,0))
QUIT
+19 IF Y'=44
IF ((Y<70)!(Y>79))
QUIT
+20 IF Y=44
SET AMQQLSS=AMQQLSS_"UNKNOWN SITE/SPECIMEN"_U
+21 IF '$TEST
SET AMQQLSS=AMQQLSS_$PIECE("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(Y-69))_U
+22 SET AMQQLSSN=AMQQLSSN+1
+23 SET AMQQLSSX=AMQQLSSX_Y_U
End DoDot:1
+24 IF 'AMQQLSSN
GOTO LEXIT
+25 SET AMQQLDS=0
+26 SET %=$PIECE(^LAB(60,AMQQLDFN,0),U,12)
+27 IF %'=""
SET %=U_%_"0)"
SET AMQQLDS=($PIECE($GET(@%),U,3)[";Trace:")
+28 IF AMQQLAKA["(HGB)"
SET AMQQLSS="BLOOD"
SET AMQQLSSN=1
+29 IF AMQQLSSN<2
Begin DoDot:1
+30 SET AMQQLSPX=$PIECE(AMQQLSSX,U)
+31 SET AMQQLOFF=+("."_$PIECE(AMQQLSSX,U))
+32 DO LN1
+33 DO LTYPE
+34 DO LHEAD^AMQQMGR4
+35 DO LSET
End DoDot:1
GOTO LEXIT
+36 FOR AMQQLI=1:1:AMQQLSSN
Begin DoDot:1
+37 SET AMQQLSPC=$PIECE(AMQQLSS,U,AMQQLI)
+38 SET AMQQLSPX=$PIECE(AMQQLSSX,U,AMQQLI)
+39 SET AMQQLOFF=+("."_AMQQLSPX)
+40 DO LN2
+41 DO LTYPE
+42 DO LHEAD^AMQQMGR4
+43 DO LSET
End DoDot:1
LEXIT KILL AMQQLSTG,AMQQLSS,AMQQLSSN,AMQQLAKA,AMQQLAKN,AMQQLHL,AMQQLHN,AMQQLHL,AMQQLOUT,AMQQLUNT,I,%,N,X,Y,Z,AMQQLOFF,AMQQLI
+1 QUIT
+2 ;
LN1 SET I=0
SET AMQQLSTG=""
+1 FOR X=1:1
SET Y=$PIECE(AMQQLAKA,U,X)
IF Y=""
QUIT
Begin DoDot:1
+2 SET I=I+1
+3 SET $PIECE(AMQQLSTG,U,I)=Y_$SELECT((AMQQLDS&(AMQQLSS["URINE")):",DIPSTICK",1:"")
+4 IF $EXTRACT(Y,U,6)="URINE "
Begin DoDot:2
+5 SET %=$SELECT(AMQQLDS:"DIPSTICK ",1:"")
+6 SET I=I+1
+7 SET $PIECE(AMQQLSTG,U,I)=$EXTRACT(Y,7,99)_","_%_"URINE"
+8 SET I=I+1
+9 SET $PIECE(AMQQLSTG,U,I)="UR "_$EXTRACT(Y,7,99)_$SELECT(%'="":(","_%),1:"")
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
LN2 SET AMQQLSTG=""
+1 SET I=0
+2 FOR Y=1:1
SET Z=$PIECE(AMQQLAKA,U,Y)
IF Z=""
QUIT
Begin DoDot:1
+3 SET I=I+1
+4 SET $PIECE(AMQQLSTG,U,I)=AMQQLSPC_" "_Z
+5 SET I=I+1
+6 SET $PIECE(AMQQLSTG,U,I)=Z_$SELECT(Z[",":" ",1:",")_AMQQLSPC
+7 IF AMQQLSPC="URINE"
SET I=I+1
SET $PIECE(AMQQLSTG,U,I)="UR "_Z
End DoDot:1
+8 QUIT
+9 ;
LTYPE IF $ORDER(^LAB(60,AMQQLDFN,200,0))
SET AMQQLTYP=""
QUIT
+1 SET %=$PIECE(^LAB(60,AMQQLDFN,0),U,12)
+2 IF %=""
GOTO TF
+3 SET %=U_%_"0)"
+4 IF '$DATA(@%)
GOTO TF
+5 IF $PIECE(@%,U,3)[";Trace:"
SET AMQQLTYP=12
QUIT
+6 IF ($PIECE(@%,U,5,6)["Q9=")+($GET(^(3))[" NUMBER ")
SET AMQQLTYP=9
QUIT
+7 IF $PIECE(@%,U,5,6)[" NUMBER "
SET AMQQLTYP=9
QUIT
+8 IF $PIECE(@%,U,3)[";Pos.:"
SET AMQQLTYP=11
QUIT
+9 IF $GET(AMQQLSTG)["TITRE"!($PIECE(@%,U,5)["""""titre""""")!($GET(^(3))["1:")
SET AMQQLTYP=15
QUIT
+10 IF $PIECE(@%,U,2)="S"
SET AMQQLTYP=6
QUIT
TF SET AMQQLTYP=2
+1 QUIT
+2 ;
LSET ;
+1 IF $DATA(AMQQLTRM)
KILL AMQQLTRM
QUIT
+2 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+3 NEW DIC,DIE,DR,DA,D,X,Y,AMQQI
+4 SET (DIC,DIE)="^AMQQ(5,"
+5 SET DIC(0)="L"
+6 SET X=$PIECE(AMQQLSTG,U)
+7 SET DINUM=AMQQLDFN+1000+AMQQLOFF
+8 IF $DATA(^AMQQ(5,DINUM))
QUIT
+9 DO FILE^DICN
+10 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+11 IF Y=-1
QUIT
+12 SET DA(1)=+Y
+13 SET DIC=DIE_DA(1)_",1,"
+14 SET DIC(0)="L"
+15 SET DIC("P")=$PIECE(^DD(9009075,.02,0),U,2)
+16 FOR AMQQI=1:1
SET X=$PIECE(AMQQLSTG,U,AMQQI)
IF X=""
QUIT
DO ^DIC
+17 SET DR="1////P;1.1////V;3////3;4////9;19////C;20////M;41////"_AMQQLTYP_";42////"_AMQQLDFN_";43////"_AMQQLSPX_";44////"_AMQQLHN_";45////"_AMQQLHL_";46////"_AMQQLUNT
+18 IF AMQQLOUT'=""
SET DR=DR_";47////^S X=AMQQLOUT"
+19 DO ^DIE
+20 KILL DR,DIC,DIE,DQ,DR,DI,D1,D0
+21 WRITE "."
+22 QUIT
+23 ;
RESCO ; RESTORE COMPANION LAB TESTS
+1 NEW DIC,X,Y,%,DA,AMQQLAB,AMQQCO
+2 IF '$DATA(^UTILITY("AMQQ LC",$JOB))
QUIT
+3 SET DIC(0)="L"
+4 SET DIC("P")=$PIECE($GET(^DD(9009075,40,0)),U,2)
+5 SET AMQQLAB=0
+6 FOR
SET AMQQLAB=$ORDER(^UTILITY("AMQQ LC",$JOB,AMQQLAB))
IF 'AMQQLAB
QUIT
SET AMQQCO=0
FOR
SET AMQQCO=$ORDER(^UTILITY("AMQQ LC",$JOB,AMQQLAB,AMQQCO))
IF 'AMQQCO
QUIT
DO ADD
WRITE "."
+7 KILL ^UTILITY("AMQQ LC",$JOB)
+8 QUIT
+9 ;
COMP ; ADD COMPANION LAB TESTS
+1 WRITE !,"Want to define new 'COMPANION' lab tests"
+2 SET %=2
+3 DO YN^DICN
+4 IF %=2
QUIT
+5 SET DIC("A")="Enter primary test name (the one that will have companions): "
PASK SET DIC="^AMQQ(5,"
+1 SET DIC(0)="AEQM"
+2 SET DIC("S")="I Y>999"
+3 DO ^DIC
+4 KILL DIC
+5 IF Y=-1
QUIT
+6 SET AMQQLAB=+Y
+7 DO CLOOK
+8 SET DIC("A")="Enter a companion test name: "
CASK SET DIC="^LAB(60,"
SET DIC(0)="AEQM"
+1 DO ^DIC
+2 KILL DIC
+3 IF Y=-1
GOTO LOOP
+4 SET AMQQCO=+Y
+5 DO CADD
+6 SET DIC("A")="Enter another companion test: "
+7 GOTO CASK
LOOP WRITE !
+1 SET DIC("A")="Enter another primary test name: "
+2 GOTO PASK
+3 ;
CADD NEW %,%Y,DIC,X,Y,DA
+1 WRITE !,"Are you sure you want to add this companion test"
+2 SET %=1
+3 DO YN^DICN
+4 IF %'=1
QUIT
+5 SET DIC(0)="L"
+6 SET DIC("P")=$PIECE($GET(^DD(9009075,40,0)),U,2)
ADD ;
+1 IF '$DATA(^AMQQ(5,AMQQLAB,0))
QUIT
+2 SET DA(1)=AMQQLAB
+3 SET DIC="^AMQQ(5,"_DA(1)_",4.1,"
+4 SET X="`"_AMQQCO
+5 DO ^DIC
+6 QUIT
+7 ;
CLOOK ;
+1 NEW X,Y
+2 IF '$ORDER(^AMQQ(5,"LC",AMQQLAB,0))
QUIT
+3 WRITE !!,"The following tests are already companions to ",$PIECE($GET(^AMQQ(5,AMQQLAB,0)),U)," =>",!
+4 SET X=0
+5 FOR
SET X=$ORDER(^AMQQ(5,"LC",AMQQLAB,X))
IF 'X
QUIT
Begin DoDot:1
+6 SET Y=$PIECE($GET(^LAB(60,+X,0)),U)
+7 IF $LENGTH(Y)
WRITE !?2,Y
End DoDot:1
+8 WRITE !!
+9 QUIT
