AMQQMGR3.m

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       ;