AMQQMGR3 ; IHS/CMI/THL - LAB STARTUP ;
;;2.0;IHS PCC SUITE;;MAY 14, 2009
;----
EN ;EP;TO CHECK ALL LABS
I '$O(^AUPNVLAB(0)) G EXAM
D ^%ZIS
I POP D EXAM Q
U IO
S AMQQLDFN=0
F S AMQQLDFN=$O(^LAB(60,AMQQLDFN)) Q:'AMQQLDFN D LAB
EXAM D ^%ZISC
EXIT K %,AMQQCONO,AMQQI,AMQQLAKA,AMQQLAKN,AMQQLC,AMQQLCO,AMQQLDFN,AMQQLDS,AMQQLHL,AMQQL1,AMQQLOFF,AMQQLOUT,AMQQLSPC,AMQQLSPX,AMQQLSS,AMQQLSSN,AMQQSSX,AMQQLSTG,AMQQLTRM,AMQQLTYP,AMQQLUNT,I,N,Y,Z
K DIRUT,DTOUT,DUOUT
Q
;
EN1 ; PROGRAMMER ENTRY POINT FOR INDIVIDUAL LAB ENTRIES
S AMQQLDFN=X
N X
F DA=AMQQLDFN+999.999999:0 S DA=$O(^AMQQ(5,DA)) Q:'DA Q:DA<(AMQQLDFN+1001) S DIK="^AMQQ(5," D ^DIK
K DIK,DA D LAB,EXIT
Q
;
LABZIS D ^%ZIS
I POP D EXIT Q
U IO D LAB
D ^%ZISC
Q
;
LAB N AMQQLIEN
S AMQQLIEN=AMQQLDFN+1000
Q:$D(^AMQQ(5,(AMQQLIEN)))
I '$D(^LAB(60,AMQQLDFN)) Q
I $P(^LAB(60,AMQQLDFN,0),U)["(" D CO^AMQQMGR4 I $D(AMQQLCOF) K AMQQLCOF Q
S X=$O(^LAB(60,AMQQLDFN,1,0))
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
S (AMQQLSS,AMQQLSSX)=""
S AMQQLSSN=0
F X=70:1:79 I $D(^LAB(60,AMQQLDFN,1,X,0)) D
.I X=70!(X=73),$D(^LAB(60,AMQQLDFN,1,72)) Q
.S AMQQLSS=AMQQLSS_$P("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(X-69))_U
.S AMQQLSSN=AMQQLSSN+1
.S AMQQLSSX=AMQQLSSX_X_U
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=0
.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
S AMQQLSTG=""
F X=1:1 S Y=$P(AMQQLAKA,U,X) Q:Y="" D LNS
Q
;
LNS 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 LNSET
Q
;
LNSET 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
S DIC="^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 DIE="^AMQQ(5,"
S DA=+Y
F AMQQI=1:1 S %=$P(AMQQLSTG,U,AMQQI) Q:%="" I $L(%)>1 S DR=".02///"_% D ^DIE
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'[":",AMQQLOUT'[";" S DR=DR_";47////"_AMQQLOUT
D ^DIE
K DR,DIC,DIE,DQ,DR,DI,D1,D0
I AMQQLOUT[";"!(AMQQLOUT[":") S $P(^AMQQ(5,DA,4),U,7)=AMQQLOUT
;W !,$P(AMQQLSTG,U)
W "."
Q
;
AQKILL ; ENTRY POINT FROM THE DD
N AMQQKKK S AMQQKKK=""
AQ ; ENTRY POINT FROM THE DD
N A,B,%
S A=^AMQQ(5,DA,4)
S A=$P(A,U)
S A=$P(^AMQQ(4,A,0),U)
I "SZTNQ"'[A Q
I $D(AMQQKKK) K ^AMQQ(5,"AQ",((DA-1000)\1)) Q
S ^AMQQ(5,"AQ",((DA-1000)\1),A)=""
Q
;
AMQQMGR3 ; IHS/CMI/THL - LAB STARTUP ;
+1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
+2 ;----
EN ;EP;TO CHECK ALL LABS
+1 IF '$ORDER(^AUPNVLAB(0))
GOTO EXAM
+2 DO ^%ZIS
+3 IF POP
DO EXAM
QUIT
+4 USE IO
+5 SET AMQQLDFN=0
+6 FOR
SET AMQQLDFN=$ORDER(^LAB(60,AMQQLDFN))
IF 'AMQQLDFN
QUIT
DO LAB
EXAM DO ^%ZISC
EXIT KILL %,AMQQCONO,AMQQI,AMQQLAKA,AMQQLAKN,AMQQLC,AMQQLCO,AMQQLDFN,AMQQLDS,AMQQLHL,AMQQL1,AMQQLOFF,AMQQLOUT,AMQQLSPC,AMQQLSPX,AMQQLSS,AMQQLSSN,AMQQSSX,AMQQLSTG,AMQQLTRM,AMQQLTYP,AMQQLUNT,I,N,Y,Z
+1 KILL DIRUT,DTOUT,DUOUT
+2 QUIT
+3 ;
EN1 ; PROGRAMMER ENTRY POINT FOR INDIVIDUAL LAB ENTRIES
+1 SET AMQQLDFN=X
+2 NEW X
+3 FOR DA=AMQQLDFN+999.999999:0
SET DA=$ORDER(^AMQQ(5,DA))
IF 'DA
QUIT
IF DA<(AMQQLDFN+1001)
QUIT
SET DIK="^AMQQ(5,"
DO ^DIK
+4 KILL DIK,DA
DO LAB
DO EXIT
+5 QUIT
+6 ;
LABZIS DO ^%ZIS
+1 IF POP
DO EXIT
QUIT
+2 USE IO
DO LAB
+3 DO ^%ZISC
+4 QUIT
+5 ;
LAB NEW AMQQLIEN
+1 SET AMQQLIEN=AMQQLDFN+1000
+2 IF $DATA(^AMQQ(5,(AMQQLIEN)))
QUIT
+3 IF '$DATA(^LAB(60,AMQQLDFN))
QUIT
+4 IF $PIECE(^LAB(60,AMQQLDFN,0),U)["("
DO CO^AMQQMGR4
IF $DATA(AMQQLCOF)
KILL AMQQLCOF
QUIT
+5 SET X=$ORDER(^LAB(60,AMQQLDFN,1,0))
+6 SET AMQQLAKA=$PIECE(^LAB(60,AMQQLDFN,0),U)
+7 SET AMQQLAKN=1
+8 SET X=0
+9 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
+10 SET (AMQQLSS,AMQQLSSX)=""
+11 SET AMQQLSSN=0
+12 FOR X=70:1:79
IF $DATA(^LAB(60,AMQQLDFN,1,X,0))
Begin DoDot:1
+13 IF X=70!(X=73)
IF $DATA(^LAB(60,AMQQLDFN,1,72))
QUIT
+14 SET AMQQLSS=AMQQLSS_$PIECE("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(X-69))_U
+15 SET AMQQLSSN=AMQQLSSN+1
+16 SET AMQQLSSX=AMQQLSSX_X_U
End DoDot:1
+17 SET AMQQLDS=0
+18 SET %=$PIECE(^LAB(60,AMQQLDFN,0),U,12)
+19 IF %'=""
SET %=U_%_"0)"
SET AMQQLDS=($PIECE($GET(@%),U,3)[";Trace:")
+20 IF AMQQLAKA["HGB^"
SET AMQQLSS="BLOOD"
SET AMQQLSSN=1
+21 IF AMQQLSSN<2
Begin DoDot:1
+22 SET AMQQLSPX=$PIECE(AMQQLSSX,U)
+23 SET AMQQLOFF=0
+24 DO LN1
+25 DO LTYPE
+26 DO LHEAD^AMQQMGR4
+27 DO LSET
End DoDot:1
GOTO LEXIT
+28 FOR AMQQLI=1:1:AMQQLSSN
Begin DoDot:1
+29 SET AMQQLSPC=$PIECE(AMQQLSS,U,AMQQLI)
+30 SET AMQQLSPX=$PIECE(AMQQLSSX,U,AMQQLI)
+31 SET AMQQLOFF=+("."_AMQQLSPX)
+32 DO LN2
+33 DO LTYPE
+34 DO LHEAD^AMQQMGR4
+35 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
+1 SET AMQQLSTG=""
+2 FOR X=1:1
SET Y=$PIECE(AMQQLAKA,U,X)
IF Y=""
QUIT
DO LNS
+3 QUIT
+4 ;
LNS SET I=I+1
+1 SET $PIECE(AMQQLSTG,U,I)=Y_$SELECT((AMQQLDS&(AMQQLSS["URINE")):",DIPSTICK",1:"")
+2 IF $EXTRACT(Y,U,6)="URINE "
Begin DoDot:1
+3 SET %=$SELECT(AMQQLDS:"DIPSTICK ",1:"")
+4 SET I=I+1
+5 SET $PIECE(AMQQLSTG,U,I)=$EXTRACT(Y,7,99)_","_%_"URINE"
+6 SET I=I+1
+7 SET $PIECE(AMQQLSTG,U,I)="UR "_$EXTRACT(Y,7,99)_$SELECT(%'="":(","_%),1:"")
End DoDot:1
+8 QUIT
+9 ;
LN2 SET AMQQLSTG=""
+1 SET I=0
+2 FOR Y=1:1
SET Z=$PIECE(AMQQLAKA,U,Y)
IF Z=""
QUIT
DO LNSET
+3 QUIT
+4 ;
LNSET SET I=I+1
+1 SET $PIECE(AMQQLSTG,U,I)=AMQQLSPC_" "_Z
+2 SET I=I+1
+3 SET $PIECE(AMQQLSTG,U,I)=Z_$SELECT(Z[",":" ",1:",")_AMQQLSPC
+4 IF AMQQLSPC="URINE"
SET I=I+1
SET $PIECE(AMQQLSTG,U,I)="UR "_Z
+5 QUIT
+6 ;
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 SET DIC="^AMQQ(5,"
+4 SET DIC(0)="L"
+5 SET X=$PIECE(AMQQLSTG,U)
+6 SET DINUM=AMQQLDFN+1000+AMQQLOFF
+7 IF $DATA(^AMQQ(5,DINUM))
QUIT
+8 DO FILE^DICN
+9 KILL DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
+10 IF Y=-1
QUIT
+11 SET DIE="^AMQQ(5,"
+12 SET DA=+Y
+13 FOR AMQQI=1:1
SET %=$PIECE(AMQQLSTG,U,AMQQI)
IF %=""
QUIT
IF $LENGTH(%)>1
SET DR=".02///"_%
DO ^DIE
+14 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
+15 IF AMQQLOUT'[":"
IF AMQQLOUT'[";"
SET DR=DR_";47////"_AMQQLOUT
+16 DO ^DIE
+17 KILL DR,DIC,DIE,DQ,DR,DI,D1,D0
+18 IF AMQQLOUT[";"!(AMQQLOUT[":")
SET $PIECE(^AMQQ(5,DA,4),U,7)=AMQQLOUT
+19 ;W !,$P(AMQQLSTG,U)
+20 WRITE "."
+21 QUIT
+22 ;
AQKILL ; ENTRY POINT FROM THE DD
+1 NEW AMQQKKK
SET AMQQKKK=""
AQ ; ENTRY POINT FROM THE DD
+1 NEW A,B,%
+2 SET A=^AMQQ(5,DA,4)
+3 SET A=$PIECE(A,U)
+4 SET A=$PIECE(^AMQQ(4,A,0),U)
+5 IF "SZTNQ"'[A
QUIT
+6 IF $DATA(AMQQKKK)
KILL ^AMQQ(5,"AQ",((DA-1000)\1))
QUIT
+7 SET ^AMQQ(5,"AQ",((DA-1000)\1),A)=""
+8 QUIT
+9 ;
