Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMQQMGR7

AMQQMGR7.m

Go to the documentation of this file. 
  1. AMQQMGR7 ; IHS/CMI/THL - LAB STARTUP OVERFLOW ;
  1.  ;;2.0;IHS PCC SUITE;;MAY 14, 2009
  1.  ;-----
  1. SAVE(AMQQLDFN) ;EP;
  1.  I '$D(^LAB(60,AMQQLDFN)) Q
  1.  S %=$P(^LAB(60,AMQQLDFN,0),U,12)
  1.  I %="" Q
  1.  I $P($G(@(U_%_"0)")),U,5)="" Q
  1.  I $P(^LAB(60,AMQQLDFN,0),U,3)="N" Q
  1.  N AMQQLSS,AMQQLSSX,AMQQLSSN,X,Y,AMQQLAKA,AMQQLAKN,AMQQLSPX,AMQQLOFF,AMQQLSPC,AMQQLDS,AMQQLTYP
  1.  S AMQQLAKA=$P(^LAB(60,AMQQLDFN,0),U)
  1.  S AMQQLAKN=1
  1.  S X=0
  1.  F  S X=$O(^LAB(60,AMQQLDFN,5,X)) Q:'X  S Y=^(X,0),AMQQLAKA=AMQQLAKA_U_Y,AMQQLAKN=AMQQLAKN+1 ; GET AKAs
  1.  S X=AMQQLDFN
  1.  S AMQQLSS=""
  1.  S AMQQLSSX=""
  1.  S AMQQLSSN=0
  1.  F  S X=$O(@TMP@(X)) Q:'X!(X>(AMQQLDFN+.99999))  D  ; GET SITE/SPECIMINES
  1.  .S Y=$G(@TMP@("C",X))
  1.  .I 'Y Q
  1.  .I Y'=44,'$D(^LAB(60,AMQQLDFN,1,Y,0)) Q
  1.  .I Y'=44,((Y<70)!(Y>79)) Q
  1.  .I Y=44 S AMQQLSS=AMQQLSS_"UNKNOWN SITE/SPECIMEN"_U
  1.  .E  S AMQQLSS=AMQQLSS_$P("BLOOD^URINE^SERUM^PLASMA^CSF^URETHRAL FLUID^PERITONEAL FLUID^PLEURAL FLUID^SYNOVIAL FLUID^CLOT",U,(Y-69))_U
  1.  .S AMQQLSSN=AMQQLSSN+1
  1.  .S AMQQLSSX=AMQQLSSX_Y_U
  1.  I 'AMQQLSSN G LEXIT
  1.  S AMQQLDS=0
  1.  S %=$P(^LAB(60,AMQQLDFN,0),U,12)
  1.  I %'="" S %=U_%_"0)",AMQQLDS=($P($G(@%),U,3)[";Trace:")
  1.  I AMQQLAKA["(HGB)" S AMQQLSS="BLOOD",AMQQLSSN=1
  1.  I AMQQLSSN<2 D  G LEXIT
  1.  .S AMQQLSPX=$P(AMQQLSSX,U)
  1.  .S AMQQLOFF=+("."_$P(AMQQLSSX,U))
  1.  .D LN1
  1.  .D LTYPE
  1.  .D LHEAD^AMQQMGR4
  1.  .D LSET
  1.  F AMQQLI=1:1:AMQQLSSN D
  1.  .S AMQQLSPC=$P(AMQQLSS,U,AMQQLI)
  1.  .S AMQQLSPX=$P(AMQQLSSX,U,AMQQLI)
  1.  .S AMQQLOFF=+("."_AMQQLSPX)
  1.  .D LN2
  1.  .D LTYPE
  1.  .D LHEAD^AMQQMGR4
  1.  .D LSET
  1. LEXIT K AMQQLSTG,AMQQLSS,AMQQLSSN,AMQQLAKA,AMQQLAKN,AMQQLHL,AMQQLHN,AMQQLHL,AMQQLOUT,AMQQLUNT,I,%,N,X,Y,Z,AMQQLOFF,AMQQLI
  1.  Q
  1.  ;
  1. LN1 S I=0,AMQQLSTG=""
  1.  F X=1:1 S Y=$P(AMQQLAKA,U,X) Q:Y=""  D
  1.  .S I=I+1
  1.  .S $P(AMQQLSTG,U,I)=Y_$S((AMQQLDS&(AMQQLSS["URINE")):",DIPSTICK",1:"")
  1.  .I $E(Y,U,6)="URINE " D
  1.  ..S %=$S(AMQQLDS:"DIPSTICK ",1:"")
  1.  ..S I=I+1
  1.  ..S $P(AMQQLSTG,U,I)=$E(Y,7,99)_","_%_"URINE"
  1.  ..S I=I+1
  1.  ..S $P(AMQQLSTG,U,I)="UR "_$E(Y,7,99)_$S(%'="":(","_%),1:"")
  1.  Q
  1.  ;
  1. LN2 S AMQQLSTG=""
  1.  S I=0
  1.  F Y=1:1 S Z=$P(AMQQLAKA,U,Y) Q:Z=""  D
  1.  .S I=I+1
  1.  .S $P(AMQQLSTG,U,I)=AMQQLSPC_" "_Z
  1.  .S I=I+1
  1.  .S $P(AMQQLSTG,U,I)=Z_$S(Z[",":" ",1:",")_AMQQLSPC
  1.  .I AMQQLSPC="URINE" S I=I+1,$P(AMQQLSTG,U,I)="UR "_Z
  1.  Q
  1.  ;
  1. LTYPE I $O(^LAB(60,AMQQLDFN,200,0)) S AMQQLTYP="" Q
  1.  S %=$P(^LAB(60,AMQQLDFN,0),U,12)
  1.  I %="" G TF
  1.  S %=U_%_"0)"
  1.  I '$D(@%) G TF
  1.  I $P(@%,U,3)[";Trace:" S AMQQLTYP=12 Q
  1.  I ($P(@%,U,5,6)["Q9=")+($G(^(3))[" NUMBER ") S AMQQLTYP=9 Q
  1.  I $P(@%,U,5,6)[" NUMBER " S AMQQLTYP=9 Q
  1.  I $P(@%,U,3)[";Pos.:" S AMQQLTYP=11 Q
  1.  I $G(AMQQLSTG)["TITRE"!($P(@%,U,5)["""""titre""""")!($G(^(3))["1:") S AMQQLTYP=15 Q
  1.  I $P(@%,U,2)="S" S AMQQLTYP=6 Q
  1. TF S AMQQLTYP=2
  1.  Q
  1.  ;
  1. LSET ;
  1.  I $D(AMQQLTRM) K AMQQLTRM Q
  1.  K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
  1.  N DIC,DIE,DR,DA,D,X,Y,AMQQI
  1.  S (DIC,DIE)="^AMQQ(5,"
  1.  S DIC(0)="L"
  1.  S X=$P(AMQQLSTG,U)
  1.  S DINUM=AMQQLDFN+1000+AMQQLOFF
  1.  Q:$D(^AMQQ(5,DINUM))
  1.  D FILE^DICN
  1.  K DIE,DIC,DINUM,DR,DA,DD,DO,DIK,DLAYGO
  1.  I Y=-1 Q
  1.  S DA(1)=+Y
  1.  S DIC=DIE_DA(1)_",1,"
  1.  S DIC(0)="L"
  1.  S DIC("P")=$P(^DD(9009075,.02,0),U,2)
  1.  F AMQQI=1:1 S X=$P(AMQQLSTG,U,AMQQI) Q:X=""  D ^DIC
  1.  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
  1.  I AMQQLOUT'="" S DR=DR_";47////^S X=AMQQLOUT"
  1.  D ^DIE
  1.  K DR,DIC,DIE,DQ,DR,DI,D1,D0
  1.  W "."
  1.  Q
  1.  ;
  1. RESCO ; RESTORE COMPANION LAB TESTS
  1.  N DIC,X,Y,%,DA,AMQQLAB,AMQQCO
  1.  I '$D(^UTILITY("AMQQ LC",$J)) Q
  1.  S DIC(0)="L"
  1.  S DIC("P")=$P($G(^DD(9009075,40,0)),U,2)
  1.  S AMQQLAB=0
  1.  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 "."
  1.  K ^UTILITY("AMQQ LC",$J)
  1.  Q
  1.  ; 
  1. COMP ; ADD COMPANION LAB TESTS
  1.  W !,"Want to define new 'COMPANION' lab tests"
  1.  S %=2
  1.  D YN^DICN
  1.  I %=2 Q
  1.  S DIC("A")="Enter primary test name (the one that will have companions): "
  1. PASK S DIC="^AMQQ(5,"
  1.  S DIC(0)="AEQM"
  1.  S DIC("S")="I Y>999"
  1.  D ^DIC
  1.  K DIC
  1.  I Y=-1 Q
  1.  S AMQQLAB=+Y
  1.  D CLOOK
  1.  S DIC("A")="Enter a companion test name: "
  1. CASK S DIC="^LAB(60,",DIC(0)="AEQM"
  1.  D ^DIC
  1.  K DIC
  1.  I Y=-1 G LOOP
  1.  S AMQQCO=+Y
  1.  D CADD
  1.  S DIC("A")="Enter another companion test: "
  1.  G CASK
  1. LOOP W !
  1.  S DIC("A")="Enter another primary test name: "
  1.  G PASK
  1.  ;
  1. CADD N %,%Y,DIC,X,Y,DA
  1.  W !,"Are you sure you want to add this companion test"
  1.  S %=1
  1.  D YN^DICN
  1.  I %'=1 Q
  1.  S DIC(0)="L"
  1.  S DIC("P")=$P($G(^DD(9009075,40,0)),U,2)
  1. ADD ;
  1.  I '$D(^AMQQ(5,AMQQLAB,0)) Q
  1.  S DA(1)=AMQQLAB
  1.  S DIC="^AMQQ(5,"_DA(1)_",4.1,"
  1.  S X="`"_AMQQCO
  1.  D ^DIC
  1.  Q
  1.  ;
  1. CLOOK ;
  1.  N X,Y
  1.  I '$O(^AMQQ(5,"LC",AMQQLAB,0)) Q
  1.  W !!,"The following tests are already companions to ",$P($G(^AMQQ(5,AMQQLAB,0)),U)," =>",!
  1.  S X=0
  1.  F  S X=$O(^AMQQ(5,"LC",AMQQLAB,X)) Q:'X  D
  1.  .S Y=$P($G(^LAB(60,+X,0)),U)
  1.  .W:$L(Y) !?2,Y
  1.  W !!
  1.  Q