AMQQMGR8 ; IHS/CMI/THL - MORE OVERFLOW FROM AMQQMGR6 ;
;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
;-----
SYN ;EP;
W !,"Print the UPDATED list of QMAN lab test names and synonyms now."
W !,"(If synonyms exist, they will be indented below the primary lab test name.)"
S DIR(0)="YO"
S DIR("A")="Print QMAN lab tests now"
S DIR("B")="NO"
W !
D ^DIR
K DIR
Q:Y'=1
SYN1 ;EP;
K ^TMP("AMQQ LAB TEST",$J)
D ^%ZIS
I POP S AMQQSTOP=1 Q
U IO D PRINT
D ^%ZISC
K ^TMP("AMQQ LAB TEST",$J),AMQQSTOP
Q
;
PRINT ;
N AMQQLIEN,AMQQDA,X,Y,Z,%,AMQQTOT,AMQQSTOP
S AMQQTOT=0
S AMQQDA=999
F S AMQQDA=$O(^AMQQ(5,AMQQDA)) Q:'AMQQDA D
.I $P($G(^AMQQ(5,AMQQDA,4)),U,8) Q
.S AMQQLIEN=(AMQQDA\1)-1000
.S X=$P($G(^LAB(60,AMQQLIEN,0)),U)
.Q:X=""
.S ^TMP("AMQQ LAB TEST",$J,X)=""
.S Z=""
.F S Z=$O(^AMQQ(5,AMQQDA,1,"B",Z)) Q:Z="" D
..S ^TMP("AMQQ LAB TEST",$J,X,Z)=""
Q:'$D(^TMP("AMQQ LAB TEST",$J))
N XX
S XX=""
F S XX=$O(^TMP("AMQQ LAB TEST",$J,XX)) Q:XX=""!$G(AMQQSTOP) D
.S Z=" "_XX
.D INC(Z)
.S Z=""
.F S Z=$O(^TMP("AMQQ LAB TEST",$J,XX,Z)) Q:Z="" D:Z'=XX
..D INC(" "_Z)
Q
;
INC(XX) ;
N %
S AMQQTOT=AMQQTOT+1
W !
I $E($G(IOST),1,2)="C-",'(AMQQTOT#20) W "<>" R %:$G(DTIME,300) W $C(13),?79,$C(13) I %=U S AMQQSTOP=1 Q
W XX
Q
;
PCO ; PRINT COMPANION TESTS
W !!,"Print the current list of companion lab tests now...."
W !,"Companion tests are indented below the primary test"
D ^%ZIS
I POP S AMQQSTOP=1 Q
U IO
D CPRINT
W !!!
D ^%ZISC
Q
;
CPRINT ;
N AMQQLAB,AMQQCO,X,AMQQTOT
S AMQQTOT=0
S AMQQLAB=0
F S AMQQLAB=$O(^AMQQ(5,"LC",AMQQLAB)) Q:'AMQQLAB D
.S XX=""
.D INC(X)
.S XX=$P($G(^AMQQ(5,AMQQLAB,0)),U)
.D INC(XX)
.S AMQQCO=0
.F S AMQQCO=$O(^AMQQ(5,"LC",AMQQLAB,AMQQCO)) Q:'AMQQCO D
..S XX=" "_$P($G(^LAB(60,AMQQCO,0)),U)
..D INC(XX)
Q
;
GETAKA ;EP;
N X,Y,DIC,DA,%,AMQQSTG,AMQQLINE,AMQQLAB,AMQQI,AMQQDA
W !,"Updating lab test synonym list..."
S DIC("P")=$P(^DD(60,2,0),U,2)
F AMQQLINE=1:1 S AMQQSTG=$$GET^AMQQMGRX(AMQQLINE) Q:AMQQSTG["***" Q:AMQQSTG="" D
.K AMQQLAB,AMQQSYN
.S AMQQSTG=$P(AMQQSTG,"; ",2)
.S AMQQLAB=$P(AMQQSTG,U)
.S X=AMQQLAB
.S DIC="^LAB(60,"
.S DIC(0)=""
.D ^DIC
.Q:Y=-1
.S AMQQDA=+Y
.F AMQQI=2:1:$L(AMQQSTG,U) S X=$P(AMQQSTG,U,AMQQI) D
..S DA(1)=AMQQDA,DIC="^LAB(60,"_DA(1)_",5,",DIC(0)="L"
..Q:$D(^LAB(60,DA(1),5,"B",X))
..D ^DIC
..I $P(Y,U,3) W "."
Q
AMQQMGR8 ; IHS/CMI/THL - MORE OVERFLOW FROM AMQQMGR6 ;
+1 ;;2.0;IHS PCC SUITE;**5**;MAY 14, 2009
+2 ;-----
SYN ;EP;
+1 WRITE !,"Print the UPDATED list of QMAN lab test names and synonyms now."
+2 WRITE !,"(If synonyms exist, they will be indented below the primary lab test name.)"
+3 SET DIR(0)="YO"
+4 SET DIR("A")="Print QMAN lab tests now"
+5 SET DIR("B")="NO"
+6 WRITE !
+7 DO ^DIR
+8 KILL DIR
+9 IF Y'=1
QUIT
SYN1 ;EP;
+1 KILL ^TMP("AMQQ LAB TEST",$JOB)
+2 DO ^%ZIS
+3 IF POP
SET AMQQSTOP=1
QUIT
+4 USE IO
DO PRINT
+5 DO ^%ZISC
+6 KILL ^TMP("AMQQ LAB TEST",$JOB),AMQQSTOP
+7 QUIT
+8 ;
PRINT ;
+1 NEW AMQQLIEN,AMQQDA,X,Y,Z,%,AMQQTOT,AMQQSTOP
+2 SET AMQQTOT=0
+3 SET AMQQDA=999
+4 FOR
SET AMQQDA=$ORDER(^AMQQ(5,AMQQDA))
IF 'AMQQDA
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^AMQQ(5,AMQQDA,4)),U,8)
QUIT
+6 SET AMQQLIEN=(AMQQDA\1)-1000
+7 SET X=$PIECE($GET(^LAB(60,AMQQLIEN,0)),U)
+8 IF X=""
QUIT
+9 SET ^TMP("AMQQ LAB TEST",$JOB,X)=""
+10 SET Z=""
+11 FOR
SET Z=$ORDER(^AMQQ(5,AMQQDA,1,"B",Z))
IF Z=""
QUIT
Begin DoDot:2
+12 SET ^TMP("AMQQ LAB TEST",$JOB,X,Z)=""
End DoDot:2
End DoDot:1
+13 IF '$DATA(^TMP("AMQQ LAB TEST",$JOB))
QUIT
+14 NEW XX
+15 SET XX=""
+16 FOR
SET XX=$ORDER(^TMP("AMQQ LAB TEST",$JOB,XX))
IF XX=""!$GET(AMQQSTOP)
QUIT
Begin DoDot:1
+17 SET Z=" "_XX
+18 DO INC(Z)
+19 SET Z=""
+20 FOR
SET Z=$ORDER(^TMP("AMQQ LAB TEST",$JOB,XX,Z))
IF Z=""
QUIT
IF Z'=XX
Begin DoDot:2
+21 DO INC(" "_Z)
End DoDot:2
End DoDot:1
+22 QUIT
+23 ;
INC(XX) ;
+1 NEW %
+2 SET AMQQTOT=AMQQTOT+1
+3 WRITE !
+4 IF $EXTRACT($GET(IOST),1,2)="C-"
IF '(AMQQTOT#20)
WRITE "<>"
READ %:$GET(DTIME,300)
WRITE $CHAR(13),?79,$CHAR(13)
IF %=U
SET AMQQSTOP=1
QUIT
+5 WRITE XX
+6 QUIT
+7 ;
PCO ; PRINT COMPANION TESTS
+1 WRITE !!,"Print the current list of companion lab tests now...."
+2 WRITE !,"Companion tests are indented below the primary test"
+3 DO ^%ZIS
+4 IF POP
SET AMQQSTOP=1
QUIT
+5 USE IO
+6 DO CPRINT
+7 WRITE !!!
+8 DO ^%ZISC
+9 QUIT
+10 ;
CPRINT ;
+1 NEW AMQQLAB,AMQQCO,X,AMQQTOT
+2 SET AMQQTOT=0
+3 SET AMQQLAB=0
+4 FOR
SET AMQQLAB=$ORDER(^AMQQ(5,"LC",AMQQLAB))
IF 'AMQQLAB
QUIT
Begin DoDot:1
+5 SET XX=""
+6 DO INC(X)
+7 SET XX=$PIECE($GET(^AMQQ(5,AMQQLAB,0)),U)
+8 DO INC(XX)
+9 SET AMQQCO=0
+10 FOR
SET AMQQCO=$ORDER(^AMQQ(5,"LC",AMQQLAB,AMQQCO))
IF 'AMQQCO
QUIT
Begin DoDot:2
+11 SET XX=" "_$PIECE($GET(^LAB(60,AMQQCO,0)),U)
+12 DO INC(XX)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
GETAKA ;EP;
+1 NEW X,Y,DIC,DA,%,AMQQSTG,AMQQLINE,AMQQLAB,AMQQI,AMQQDA
+2 WRITE !,"Updating lab test synonym list..."
+3 SET DIC("P")=$PIECE(^DD(60,2,0),U,2)
+4 FOR AMQQLINE=1:1
SET AMQQSTG=$$GET^AMQQMGRX(AMQQLINE)
IF AMQQSTG["***"
QUIT
IF AMQQSTG=""
QUIT
Begin DoDot:1
+5 KILL AMQQLAB,AMQQSYN
+6 SET AMQQSTG=$PIECE(AMQQSTG,"; ",2)
+7 SET AMQQLAB=$PIECE(AMQQSTG,U)
+8 SET X=AMQQLAB
+9 SET DIC="^LAB(60,"
+10 SET DIC(0)=""
+11 DO ^DIC
+12 IF Y=-1
QUIT
+13 SET AMQQDA=+Y
+14 FOR AMQQI=2:1:$LENGTH(AMQQSTG,U)
SET X=$PIECE(AMQQSTG,U,AMQQI)
Begin DoDot:2
+15 SET DA(1)=AMQQDA
SET DIC="^LAB(60,"_DA(1)_",5,"
SET DIC(0)="L"
+16 IF $DATA(^LAB(60,DA(1),5,"B",X))
QUIT
+17 DO ^DIC
+18 IF $PIECE(Y,U,3)
WRITE "."
End DoDot:2
End DoDot:1
+19 QUIT
