AMQQMGR9 ;IHS/CMI/THL - AMQQMGR CONTINUED ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
;-----
EN ;EP;TO ADD LABS TO THE QMAN DICTIONARY OF TERM
D EN1
EXIT K AMQQ,AMQQQUIT
K ^TMP("AMQQ",$J)
Q
EN1 S AMQQLDFN=0
F S AMQQLDFN=$O(^LAB(60,AMQQLDFN)) Q:'AMQQLDFN D
.D LCHK
.S AMQQLSDA=0
.F S AMQQLSDA=$O(^LAB(60,AMQQLDFN,1,AMQQLSDA)) Q:'AMQQLSDA D
..D LSCHK
Q
LCHK ;CHECK TO SEE IF LAB ALREADY IN METADICTIONARY
;ADD IF NOT
S AMQQLIEN=AMQQLDFN+1000
Q:$D(^AMQQ(5,AMQQLIEN,0))
S X=AMQQLDFN
S DINUM=AMQQLIEN
S DIC="^AMQQ(5,"
S DIC(0)="L"
S DIC("DR")=""
D FILE^DICN
K DIC,DA,DR,DINUM
D LTYPE
W !,"LAB TEST: ",AMQQLIEN
Q
LSCHK ;CHECK TO SEE IF LAB TEST SITE/SPECIMEN ALREADY IN METADICTIONARY
;ADD IF NOT
S AMQQLSEN=AMQQLDFN+1000+(AMQQLSDA/100)
Q:$D(^AMQQ(5,AMQQLSEN,0))
S X=AMQQLDFN
S DINUM=AMQQLSEN
S DIC="^AMQQ(5,"
S DIC(0)="L"
S DIC("DR")=""
D FILE^DICN
K DIC,DA,DR,DINUM
D LTYPE
W !,"SITE/SPECIMEN: ",AMQQLSEN
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
IMM ;EP;TO ADD NEW IMMUNIZATIONS TO QMAN DICTIONARIES OF LINKS AND TERMS
N XX,X,Y,Z
S J=849
S XX=0
F S XX=$O(^AUTTIMM(XX)) Q:'XX D:'$D(^AMQQ(1,"IMM",XX))
.F DA=850:1 Q:DA>999!'$D(^AMQQ(1,DA,0))
.Q:DA>999!'DA
.S X=$G(^AUTTIMM(XX,0))
.Q:X=""
.S J=J+1
.S NAME=$P(X,U)
.S SNAME=$P(X,U,2)
.S CODE=$P(X,U,3)
.M ^AMQQ(1,DA)=^AMQQ(1,472)
.M ^AMQQ(5,DA)=^AMQQ(5,472)
.S $P(^AMQQ(5,DA,0),U)=NAME
.S $P(^AMQQ(5,DA,0),U,5)=DA
.S $P(^AMQQ(5,DA,0),U,12)="IMM;"_CODE
.K ^AMQQ(5,DA,1)
.S ^AMQQ(5,DA,1,0)="^9009075.01^2^2"
.S ^AMQQ(5,DA,1,1,0)=NAME
.S ^AMQQ(5,DA,1,2,0)=SNAME
.S ^AMQQ(5,DA,1,"B",NAME,1)=""
.S ^AMQQ(5,DA,1,"B",SNAME,2)=""
.S $P(^AMQQ(1,DA,0),U,11)=XX
.S $P(^AMQQ(1,DA,0),U,15)=XX
.S $P(^AMQQ(1,DA,0),U)="PATIENT;"_NAME
.S $P(^AMQQ(1,DA,1),";",2)=XX
.S $P(^AMQQ(1,DA,2),";",2)=XX
.S DIK="^AMQQ(1,"
.D IX1^DIK
.S DIK="^AMQQ(5,"
.D IX1^DIK
Q
MSR ;EP;TO ADD NEW MEASUREMENTS TO QMAN DICTIONARIES OF LINKS AND TERMS
;PATCH XXX
K ^TMP($J,"AMQQ MSR")
S XX=0
F S XX=$O(^AMQQ(1,"MSR",XX)) Q:'XX I $P($G(^AUTTMSR(XX,0)),U)]"" S ^TMP($J,"AMQQ MSR",$P(^(0),U))=""
N XX,X,Y,Z
S XX=0
F S XX=$O(^AUTTMSR(XX)) Q:'XX D:'$D(^AMQQ(1,"MSR",XX))
.F DA=1:1 Q:DA>999!('$D(^AMQQ(1,DA,0))&'$D(^AMQQ(5,DA,0)))
.Q:DA>999!'DA
.S X=$G(^AUTTMSR(XX,0))
.Q:X=""
.S SNAME=$P(X,U)
.S NAME=$P(X,U,2)
.S CODE=$P(X,U,3)
.Q:$D(^TMP($J,"AMQQ MSR",SNAME))
.S ^TMP($J,"AMQQ MSR",SNAME)=""
.W:'$D(ZTQUEUED) !,DA,?10,XX,?20,NAME,?50,SNAME,?60,CODE
.M ^AMQQ(1,DA)=^AMQQ(1,751)
.M ^AMQQ(5,DA)=^AMQQ(5,751)
.S $P(^AMQQ(5,DA,0),U)=NAME
.S $P(^AMQQ(5,DA,0),U,5)=DA
.S $P(^AMQQ(5,DA,0),U,12)="MSR;"_CODE
.K ^AMQQ(5,DA,1)
.S ^AMQQ(5,DA,1,0)="^9009075.01^2^2"
.S ^AMQQ(5,DA,1,1,0)=NAME
.S ^AMQQ(5,DA,1,2,0)=SNAME
.S ^AMQQ(5,DA,1,"B",NAME,1)=""
.S ^AMQQ(5,DA,1,"B",SNAME,2)=""
.S $P(^AMQQ(1,DA,0),U,9)=CODE
.S $P(^AMQQ(1,DA,0),U,11)=XX
.S $P(^AMQQ(1,DA,0),U,15)=XX
.S $P(^AMQQ(1,DA,0),U)="PATIENT;"_NAME
.S $P(^AMQQ(1,DA,1),";",2)=XX
.S $P(^AMQQ(1,DA,2),";",2)=XX
.S X=^AMQQ(1,DA,1)
.S X=$P(X,"$D(^(AMQP(0),")_"$D(^(AMQP(0),"_XX_")) S AMQQX="_$P(X,")) S AMQQX=",2)
.K ^AMQQ(1,DA,4,"B")
.S $P(^AMQQ(1,DA,4,1,0),U)=SNAME
.S $P(^AMQQ(1,DA,4,1,0),U,4)=$E(NAME,1,7)
.S $P(^AMQQ(1,DA,4,2,0),U)="DATE OF "_SNAME
.S $P(^AMQQ(1,DA,4,2,0),U,4)="DATE OF "_SNAME
.S DIK="^AMQQ(1,"
.D IX1^DIK
.S DIK="^AMQQ(5,"
.D IX1^DIK
K ^TMP($J,"AMQQ MSR")
Q
EXAM ;EP;TO ADD NEW EXAMS TO QMAN DICTIONARIES OF LINKS AND TERMS
;PATCH XXX
K ^TMP($J,"AMQQ EXAM")
S XX=0
F S XX=$O(^AMQQ(1,"EXAM",XX)) Q:'XX I $P($G(^AUTTEXAM(XX,0)),U,2)]"" S ^TMP($J,"AMQQ EXAM",$P(^(0),U,2))=""
N XX,X,Y,Z
S XX=0
F S XX=$O(^AUTTEXAM(XX)) Q:'XX D:'$D(^AMQQ(1,"XAM",XX))
.F DA=1:1 Q:DA>999!('$D(^AMQQ(1,DA,0))&'$D(^AMQQ(5,DA,0)))
.Q:DA>999!'DA
.S X=$G(^AUTTEXAM(XX,0))
.Q:X=""
.S NAME=$P(X,U)
.S CODE=$P(X,U,2)
.Q:$D(^TMP($J,"AMQQ EXAM",CODE))
.S ^TMP($J,"AMQQ EXAM",CODE)=""
.M ^AMQQ(1,DA)=^AMQQ(1,751)
.M ^AMQQ(5,DA)=^AMQQ(5,751)
.S $P(^AMQQ(5,DA,0),U)=NAME
.S $P(^AMQQ(5,DA,0),U,5)=DA
.S $P(^AMQQ(5,DA,0),U,12)="EXAM;"_CODE
.K ^AMQQ(5,DA,1)
.S ^AMQQ(5,DA,1,0)="^9009075.01^2^2"
.S ^AMQQ(5,DA,1,1,0)=NAME
.S ^AMQQ(5,DA,1,"B",NAME,1)=""
.S $P(^AMQQ(1,DA,0),U,9)=CODE
.S $P(^AMQQ(1,DA,0),U,11)=XX
.S $P(^AMQQ(1,DA,0),U,15)=XX
.S $P(^AMQQ(1,DA,0),U)="PATIENT;"_NAME
.S $P(^AMQQ(1,DA,1),";",2)=XX
.S $P(^AMQQ(1,DA,2),";",2)=XX
.K ^AMQQ(1,DA,4,"B")
.S $P(^AMQQ(1,DA,4,1,0),U)=SNAME
.S $P(^AMQQ(1,DA,4,1,0),U,4)=$E(NAME,1,7)
.S $P(^AMQQ(1,DA,4,2,0),U)="DATE OF "_SNAME
.S $P(^AMQQ(1,DA,4,2,0),U,4)="DATE OF "_SNAME
.S DIK="^AMQQ(1,"
.D IX1^DIK
.S DIK="^AMQQ(5,"
.D IX1^DIK
K ^TMP($J,"AMQQ EXAM")
Q
IEN ;EP;TO RESET EXAM AND MEASUREMENT IEN'S ; PATCH XXX
F DA=1:1 Q:DA>999 S X=$G(^AMQQ(1,DA,1)) D:X["AUPNVMSR"!(X["AUPNVXAM")
.S XX=$P(X,";",2)
.S X=$P(X,"$D(^(AMQP(0),")_"$D(^(AMQP(0),"_XX_")) S AMQQX="_$P(X,")) S AMQQX=",2)
.S ^AMQQ(1,DA,1)=X
Q
AMQQMGR9 ;IHS/CMI/THL - AMQQMGR CONTINUED ;
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
+2 ;-----
EN ;EP;TO ADD LABS TO THE QMAN DICTIONARY OF TERM
+1 DO EN1
EXIT KILL AMQQ,AMQQQUIT
+1 KILL ^TMP("AMQQ",$JOB)
+2 QUIT
EN1 SET AMQQLDFN=0
+1 FOR
SET AMQQLDFN=$ORDER(^LAB(60,AMQQLDFN))
IF 'AMQQLDFN
QUIT
Begin DoDot:1
+2 DO LCHK
+3 SET AMQQLSDA=0
+4 FOR
SET AMQQLSDA=$ORDER(^LAB(60,AMQQLDFN,1,AMQQLSDA))
IF 'AMQQLSDA
QUIT
Begin DoDot:2
+5 DO LSCHK
End DoDot:2
End DoDot:1
+6 QUIT
LCHK ;CHECK TO SEE IF LAB ALREADY IN METADICTIONARY
+1 ;ADD IF NOT
+2 SET AMQQLIEN=AMQQLDFN+1000
+3 IF $DATA(^AMQQ(5,AMQQLIEN,0))
QUIT
+4 SET X=AMQQLDFN
+5 SET DINUM=AMQQLIEN
+6 SET DIC="^AMQQ(5,"
+7 SET DIC(0)="L"
+8 SET DIC("DR")=""
+9 DO FILE^DICN
+10 KILL DIC,DA,DR,DINUM
+11 DO LTYPE
+12 WRITE !,"LAB TEST: ",AMQQLIEN
+13 QUIT
LSCHK ;CHECK TO SEE IF LAB TEST SITE/SPECIMEN ALREADY IN METADICTIONARY
+1 ;ADD IF NOT
+2 SET AMQQLSEN=AMQQLDFN+1000+(AMQQLSDA/100)
+3 IF $DATA(^AMQQ(5,AMQQLSEN,0))
QUIT
+4 SET X=AMQQLDFN
+5 SET DINUM=AMQQLSEN
+6 SET DIC="^AMQQ(5,"
+7 SET DIC(0)="L"
+8 SET DIC("DR")=""
+9 DO FILE^DICN
+10 KILL DIC,DA,DR,DINUM
+11 DO LTYPE
+12 WRITE !,"SITE/SPECIMEN: ",AMQQLSEN
+13 QUIT
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
IMM ;EP;TO ADD NEW IMMUNIZATIONS TO QMAN DICTIONARIES OF LINKS AND TERMS
+1 NEW XX,X,Y,Z
+2 SET J=849
+3 SET XX=0
+4 FOR
SET XX=$ORDER(^AUTTIMM(XX))
IF 'XX
QUIT
IF '$DATA(^AMQQ(1,"IMM",XX))
Begin DoDot:1
+5 FOR DA=850:1
IF DA>999!'$DATA(^AMQQ(1,DA,0))
QUIT
+6 IF DA>999!'DA
QUIT
+7 SET X=$GET(^AUTTIMM(XX,0))
+8 IF X=""
QUIT
+9 SET J=J+1
+10 SET NAME=$PIECE(X,U)
+11 SET SNAME=$PIECE(X,U,2)
+12 SET CODE=$PIECE(X,U,3)
+13 MERGE ^AMQQ(1,DA)=^AMQQ(1,472)
+14 MERGE ^AMQQ(5,DA)=^AMQQ(5,472)
+15 SET $PIECE(^AMQQ(5,DA,0),U)=NAME
+16 SET $PIECE(^AMQQ(5,DA,0),U,5)=DA
+17 SET $PIECE(^AMQQ(5,DA,0),U,12)="IMM;"_CODE
+18 KILL ^AMQQ(5,DA,1)
+19 SET ^AMQQ(5,DA,1,0)="^9009075.01^2^2"
+20 SET ^AMQQ(5,DA,1,1,0)=NAME
+21 SET ^AMQQ(5,DA,1,2,0)=SNAME
+22 SET ^AMQQ(5,DA,1,"B",NAME,1)=""
+23 SET ^AMQQ(5,DA,1,"B",SNAME,2)=""
+24 SET $PIECE(^AMQQ(1,DA,0),U,11)=XX
+25 SET $PIECE(^AMQQ(1,DA,0),U,15)=XX
+26 SET $PIECE(^AMQQ(1,DA,0),U)="PATIENT;"_NAME
+27 SET $PIECE(^AMQQ(1,DA,1),";",2)=XX
+28 SET $PIECE(^AMQQ(1,DA,2),";",2)=XX
+29 SET DIK="^AMQQ(1,"
+30 DO IX1^DIK
+31 SET DIK="^AMQQ(5,"
+32 DO IX1^DIK
End DoDot:1
+33 QUIT
MSR ;EP;TO ADD NEW MEASUREMENTS TO QMAN DICTIONARIES OF LINKS AND TERMS
+1 ;PATCH XXX
+2 KILL ^TMP($JOB,"AMQQ MSR")
+3 SET XX=0
+4 FOR
SET XX=$ORDER(^AMQQ(1,"MSR",XX))
IF 'XX
QUIT
IF $PIECE($GET(^AUTTMSR(XX,0)),U)]""
SET ^TMP($JOB,"AMQQ MSR",$PIECE(^(0),U))=""
+5 NEW XX,X,Y,Z
+6 SET XX=0
+7 FOR
SET XX=$ORDER(^AUTTMSR(XX))
IF 'XX
QUIT
IF '$DATA(^AMQQ(1,"MSR",XX))
Begin DoDot:1
+8 FOR DA=1:1
IF DA>999!('$DATA(^AMQQ(1,DA,0))&'$DATA(^AMQQ(5,DA,0)))
QUIT
+9 IF DA>999!'DA
QUIT
+10 SET X=$GET(^AUTTMSR(XX,0))
+11 IF X=""
QUIT
+12 SET SNAME=$PIECE(X,U)
+13 SET NAME=$PIECE(X,U,2)
+14 SET CODE=$PIECE(X,U,3)
+15 IF $DATA(^TMP($JOB,"AMQQ MSR",SNAME))
QUIT
+16 SET ^TMP($JOB,"AMQQ MSR",SNAME)=""
+17 IF '$DATA(ZTQUEUED)
WRITE !,DA,?10,XX,?20,NAME,?50,SNAME,?60,CODE
+18 MERGE ^AMQQ(1,DA)=^AMQQ(1,751)
+19 MERGE ^AMQQ(5,DA)=^AMQQ(5,751)
+20 SET $PIECE(^AMQQ(5,DA,0),U)=NAME
+21 SET $PIECE(^AMQQ(5,DA,0),U,5)=DA
+22 SET $PIECE(^AMQQ(5,DA,0),U,12)="MSR;"_CODE
+23 KILL ^AMQQ(5,DA,1)
+24 SET ^AMQQ(5,DA,1,0)="^9009075.01^2^2"
+25 SET ^AMQQ(5,DA,1,1,0)=NAME
+26 SET ^AMQQ(5,DA,1,2,0)=SNAME
+27 SET ^AMQQ(5,DA,1,"B",NAME,1)=""
+28 SET ^AMQQ(5,DA,1,"B",SNAME,2)=""
+29 SET $PIECE(^AMQQ(1,DA,0),U,9)=CODE
+30 SET $PIECE(^AMQQ(1,DA,0),U,11)=XX
+31 SET $PIECE(^AMQQ(1,DA,0),U,15)=XX
+32 SET $PIECE(^AMQQ(1,DA,0),U)="PATIENT;"_NAME
+33 SET $PIECE(^AMQQ(1,DA,1),";",2)=XX
+34 SET $PIECE(^AMQQ(1,DA,2),";",2)=XX
+35 SET X=^AMQQ(1,DA,1)
+36 SET X=$PIECE(X,"$D(^(AMQP(0),")_"$D(^(AMQP(0),"_XX_")) S AMQQX="_$PIECE(X,")) S AMQQX=",2)
+37 KILL ^AMQQ(1,DA,4,"B")
+38 SET $PIECE(^AMQQ(1,DA,4,1,0),U)=SNAME
+39 SET $PIECE(^AMQQ(1,DA,4,1,0),U,4)=$EXTRACT(NAME,1,7)
+40 SET $PIECE(^AMQQ(1,DA,4,2,0),U)="DATE OF "_SNAME
+41 SET $PIECE(^AMQQ(1,DA,4,2,0),U,4)="DATE OF "_SNAME
+42 SET DIK="^AMQQ(1,"
+43 DO IX1^DIK
+44 SET DIK="^AMQQ(5,"
+45 DO IX1^DIK
End DoDot:1
+46 KILL ^TMP($JOB,"AMQQ MSR")
+47 QUIT
EXAM ;EP;TO ADD NEW EXAMS TO QMAN DICTIONARIES OF LINKS AND TERMS
+1 ;PATCH XXX
+2 KILL ^TMP($JOB,"AMQQ EXAM")
+3 SET XX=0
+4 FOR
SET XX=$ORDER(^AMQQ(1,"EXAM",XX))
IF 'XX
QUIT
IF $PIECE($GET(^AUTTEXAM(XX,0)),U,2)]""
SET ^TMP($JOB,"AMQQ EXAM",$PIECE(^(0),U,2))=""
+5 NEW XX,X,Y,Z
+6 SET XX=0
+7 FOR
SET XX=$ORDER(^AUTTEXAM(XX))
IF 'XX
QUIT
IF '$DATA(^AMQQ(1,"XAM",XX))
Begin DoDot:1
+8 FOR DA=1:1
IF DA>999!('$DATA(^AMQQ(1,DA,0))&'$DATA(^AMQQ(5,DA,0)))
QUIT
+9 IF DA>999!'DA
QUIT
+10 SET X=$GET(^AUTTEXAM(XX,0))
+11 IF X=""
QUIT
+12 SET NAME=$PIECE(X,U)
+13 SET CODE=$PIECE(X,U,2)
+14 IF $DATA(^TMP($JOB,"AMQQ EXAM",CODE))
QUIT
+15 SET ^TMP($JOB,"AMQQ EXAM",CODE)=""
+16 MERGE ^AMQQ(1,DA)=^AMQQ(1,751)
+17 MERGE ^AMQQ(5,DA)=^AMQQ(5,751)
+18 SET $PIECE(^AMQQ(5,DA,0),U)=NAME
+19 SET $PIECE(^AMQQ(5,DA,0),U,5)=DA
+20 SET $PIECE(^AMQQ(5,DA,0),U,12)="EXAM;"_CODE
+21 KILL ^AMQQ(5,DA,1)
+22 SET ^AMQQ(5,DA,1,0)="^9009075.01^2^2"
+23 SET ^AMQQ(5,DA,1,1,0)=NAME
+24 SET ^AMQQ(5,DA,1,"B",NAME,1)=""
+25 SET $PIECE(^AMQQ(1,DA,0),U,9)=CODE
+26 SET $PIECE(^AMQQ(1,DA,0),U,11)=XX
+27 SET $PIECE(^AMQQ(1,DA,0),U,15)=XX
+28 SET $PIECE(^AMQQ(1,DA,0),U)="PATIENT;"_NAME
+29 SET $PIECE(^AMQQ(1,DA,1),";",2)=XX
+30 SET $PIECE(^AMQQ(1,DA,2),";",2)=XX
+31 KILL ^AMQQ(1,DA,4,"B")
+32 SET $PIECE(^AMQQ(1,DA,4,1,0),U)=SNAME
+33 SET $PIECE(^AMQQ(1,DA,4,1,0),U,4)=$EXTRACT(NAME,1,7)
+34 SET $PIECE(^AMQQ(1,DA,4,2,0),U)="DATE OF "_SNAME
+35 SET $PIECE(^AMQQ(1,DA,4,2,0),U,4)="DATE OF "_SNAME
+36 SET DIK="^AMQQ(1,"
+37 DO IX1^DIK
+38 SET DIK="^AMQQ(5,"
+39 DO IX1^DIK
End DoDot:1
+40 KILL ^TMP($JOB,"AMQQ EXAM")
+41 QUIT
IEN ;EP;TO RESET EXAM AND MEASUREMENT IEN'S ; PATCH XXX
+1 FOR DA=1:1
IF DA>999
QUIT
SET X=$GET(^AMQQ(1,DA,1))
IF X["AUPNVMSR"!(X["AUPNVXAM")
Begin DoDot:1
+2 SET XX=$PIECE(X,";",2)
+3 SET X=$PIECE(X,"$D(^(AMQP(0),")_"$D(^(AMQP(0),"_XX_")) S AMQQX="_$PIECE(X,")) S AMQQX=",2)
+4 SET ^AMQQ(1,DA,1)=X
End DoDot:1
+5 QUIT
