LA7PCFG ;VA/DALOI/JMC - Configrure Lab Point of Care Interface; Jan 12, 2004
;;5.2;AUTOMATED LAB INSTRUMENTS;**1031**;NOV 01, 1997
;
;;VA LA Patche(s): 67
;
; Reference to DIV4^XUSER supported by DBIA #2533
Q
;
EN ; Configure files #62.48, #62.4 and #68.2
N DIR,DIROUT,DIRUT,DUOUT,LA7QUIT,LRLL,X,Y
S LRLL=0
F D Q:$D(DIRUT)
. S DIR(0)="SO^1:LA7 MESSAGE PARAMETER (#62.48);2:LOAD/WORK LIST (#68.2);3:AUTO INSTRUMENT (#62.4);4:Print POC Test Code Mapping"
. S DIR("A")="Select which file to setup"
. D ^DIR
. I $D(DIRUT) Q
. I Y=1 D E6248 Q
. I Y=2 D E682 Q
. I Y=3 D E624 Q
. I Y=4 D PRINT Q
Q
;
;
E6248 ; Setup/edit file #62.48
;
N DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,LA76248,LA7TYP,X,Y
D EN^DDIOL("","","!!")
S DIC="^LAHM(62.48,",DIC(0)="AEMQ",DIC("S")="I $P(^(0),U,9)=20!($P(^(0),U,9)=21)"
D ^DIC
I Y<1 Q
S (DA,LA76248)=+Y
L +^LAHM(62.48,LA76248):0
I '$T D EN^DDIOL("Another user is editing this entry.","","!?5") Q
D EN^DDIOL("","","!!")
S DIR(0)="YO"
S DIR("A")="Does this POC interface want to receive VistA ADT messages"
S DIR("B")=$S($P($G(^LAHM(62.48,LA76248,0)),"^",9)=21:"YES",1:"NO")
D ^DIR
I $D(DIRUT) Q
S LA7TYP=$S(Y=1:21,1:20)
I LA7TYP=21 D
. D EN^DDIOL("Remember to add the LA7POC ADT RTR event protocol to the appropriate","","!!")
. D EN^DDIOL("ADT event protocols as specified in the Lab POC User Guide","","!")
. D EN^DDIOL("","","!!")
S DIE=DIC,DR="11///"_LA7TYP_";2;3;4///ON;20"
D ^DIE
L -^LAHM(62.48,LA76248)
Q
;
;
E624 ; Setup/edit file #62.4
;
N DA,DIC,DIE,DR,LA7624,LA76248,LA7ERR,LRNLT,LRX,LRY,X,Y
;
D EN^DDIOL("","","!")
S DIC="^LAB(62.4,",DIC(0)="AEMQ",DIC("S")="I $E($P(^(0),U),1,6)=""LA7POC"""
D ^DIC
I Y<1 Q
S (DA,LA7624)=+Y
L +^LAB(62.4,LA7624):0
I '$T D EN^DDIOL("Another user is editing this entry.","","!?5") Q
S DIE=DIC
S DR="3"_$S(LRLL>0:"//"_$$GET1^DIQ(68.2,LRLL_",",.01),1:"")_";8;10;11;12////0;18;30;107"
S DR(2,62.41)=".01;S LRNLT=$$GET1^DIQ(64,+$P($G(^LAB(60,X,64)),U,2)_"","",1);2;6////^S X=LRNLT;8R;12;13;14;17;18;19;21//YES"
D ^DIE
;
; Check if loadlist type = POC
I $P(^LAB(62.4,LA7624,0),"^",4) D
. S LRLL=$P(^LAB(62.4,LA7624,0),"^",4)
. I $P(^LRO(68.2,LRLL,0),"^",3)'=2 D EN^DDIOL("**WARNING-Associated Load/Work List "_$$GET1^DIQ(68.2,LRLL_",",.01)_" is not TYPE: POINT OF CARE**","","!?2")
;
; Check if 62.4 name matches 62.48 name
I $P(^LAB(62.4,LA7624,0),"^",8) D
. S LRX=$$GET1^DIQ(62.48,$P(^LAB(62.4,LA7624,0),"^",8)_",",.01)
. S LRY=$$GET1^DIQ(62.4,LA7624_",",.01)
. I LRX'=LRY D EN^DDIOL("**WARNING-Name of entry in AUTO INSTRUMENT file should match name of MESSAGE CONFIGURATION**","","!?2")
;
L -^LAB(62.4,LA7624)
Q
;
;
E682 ; Setup/edit file #68.2
N DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DUOUT,I
N LA7ERR,LR60,LR61,LRAA,LRDIV,LRMSG,LRPROF,LRX,LRY,X,Y
;
D EN^DDIOL("","","!")
S DIC="^LRO(68.2,",DIC(0)="AELMQ"
I LRLL>0 S DIC("B")=$$GET1^DIQ(68.2,LRLL_",",.01)
D ^DIC
I Y<1 Q
S (DA,LRLL)=+Y
L +^LRO(68.2,LRLL):0
I '$T D EN^DDIOL("Another user is editing this entry.","","!?5") Q
S DIE=DIC
S DR=".01;.02///UNIVERSAL;.03///2;.08///ACCESSION;.14;1;1.5;1.7;50"
S DR(2,68.23)=".01;2;2.2;1"
S DR(3,68.24)=".01;I ""IB""'[$P(^LAB(60,X,0),""^"",3) S Y=2;1R;3;4;2///NO"
D ^DIE
L -^LRO(68.2,LRLL)
W !
;
S LRPROF=$O(^LRO(68.2,LRLL,10,0))
I LRPROF<1 D Q
. D EN^DDIOL($C(7)_"*** Need at least one profile for POC interface ***","","!!")
;
I $O(^LRO(68.2,LRLL,10,LRPROF)) D Q
. D EN^DDIOL($C(7)_"*** Only one profile should exist for POC interface ***","","!!")
;
S LRAA=$P($G(^LRO(68.2,LRLL,10,LRPROF,0)),U,2)
I 'LRAA Q
;
; Check tests on profile for specimen/collection sample
S I=0
F S I=$O(^LRO(68.2,LRLL,10,LRPROF,1,I)) Q:'I D
. S LRX=$G(^LRO(68.2,LRLL,10,LRPROF,1,I,0))
. S LR60=$P(LRX,"^"),LR61=$P(LRX,"^",2)
. S LR60(0)=^LAB(60,LR60,0)
. I "IB"[$P(LR60(0),"^",3) D
. . I 'LR61 D Q
. . . S LRMSG(I)=$P(LR60(0),"^")_" missing specimen"
. . I '$P(LRX,"^",5) D
. . . S LRMSG(I)=$P(LR60(0),"^")_" missing collection sample for specimen "_$P(^LAB(61,LR61,0),"^")
I $D(LRMSG) D EN^DDIOL(.LRMSG,"","")
;
D EN^DDIOL("Now edit the associated division for accession area "_$$GET1^DIQ(68,LRAA_",",.01)_".","","!!")
S DA=LRAA,DIE="^LRO(68,",DR=".091"
D ^DIE
;
S LRDIV=$O(^LRO(68,LRAA,3,0))
I 'LRDIV D Q
. D EN^DDIOL("*** A division needs to be associated with this POC accession area ***","","!!")
;
I $O(^LRO(68,LRAA,3,LRDIV)) D
. D EN^DDIOL($C(7)_"*** Lab POC software will use "_$P($$NS^XUAF4(LRDIV),"^"),"","!!")
. D EN^DDIOL("as the default division with this accession area ***","","!?4")
;
S LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
I LRX<1 D EN^DDIOL($C(7)_"*** Unable to identify user 'LRLAB,POC' in NEW PERSON file ***","","!!")
I LRX>0 D
. K LRY
. S LRY=$$DIV4^XUSER(.LRY,LRX)
. I $D(LRY(LRDIV)) Q
. D EN^DDIOL($C(7)_"*** Have IRM assign division "_$P($$NS^XUAF4(LRDIV),"^")_" to user 'LRLAB,POC' ***","","!!")
Q
;
;
PRINT ; Print test code mappings for POC setup
N %ZIS,DIC,LA7624,ZTDTH,ZTSK,ZTRTN,ZTIO,ZTSAVE,X,Y
;
D EN^DDIOL("","","!")
S DIC="^LAB(62.4,",DIC(0)="AEMQ",DIC("S")="I $E($P(^(0),U),1,6)=""LA7POC"""
D ^DIC
I Y<1 Q
S LA7624=+Y
;
S %ZIS="MQ" D ^%ZIS
I POP D HOME^%ZIS Q
I $D(IO("Q")) D Q
. S ZTRTN="DQP^LA7PCFG",ZTSAVE("LA7624")="",ZTDESC="Print POC Setup"
. D ^%ZTLOAD,^%ZISC
. D EN^DDIOL("Request "_$S($G(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
;
DQP ; entry point from above and TaskMan
;
N I,X,Y
N LA7EXIT,LA7INTYP,LA7LINE,LA7LINE2,LA7NOW,LA7PAGE,LA7CODE
N LA76248,LR60,LR61,LR62,LR64,LR642,LRLL,LRPROF
S LA7NOW=$$HTE^XLFDT($H,"1D"),(LA7EXIT,LA7PAGE)=0
S LA7624(0)=$G(^LAB(62.4,LA7624,0))
S LA76248=$P(LA7624(0),"^",8)
S LA7INTYP=$P(^LAHM(62.48,LA76248,0),"^",9)
S LRLL=$P(LA7624(0),"^",4)
S LRPROF=$O(^LRO(68.2,LRLL,10,0))
S LA7LINE=$$REPEAT^XLFSTR("=",IOM)
S LA7LINE2=$$REPEAT^XLFSTR("-",IOM)
D HDR
W !!,"VistA ADT feed enabled: ",$S(LA7INTYP=21:"YES",LA7INTYP=20:"NO",1:"UNKNOWN"),!!
D SH1
;
S I=0
F S I=$O(^LRO(68.2,LRLL,10,LRPROF,1,I)) Q:'I D Q:LA7EXIT
. I ($Y+6)>IOSL D HDR Q:LA7EXIT D SH1 Q:LA7EXIT
. S X=^LRO(68.2,LRLL,10,LRPROF,1,I,0)
. S LR60=+X,LR64=+$G(^LAB(60,LR60,64)),LR64(0)=$G(^LAM(LR64,0))
. S LR61=$P(X,"^",2),LR642=$P(X,"^",4),LR62=0
. I LR61 S LR62=$P(X,"^",5)
. I 'LR62,LR61 S LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
. W !,$J(I,2),?3,$E($P(^LAB(60,LR60,0),"^"),1,25)
. S X=$P(LR64(0),"^",2)
. W ?30,$S(X'="":X,1:"<Missing>")
. I LR61 D
. . S X="("_LR61_")"
. . S X=$E($P(^LAB(61,LR61,0),"^"),1,19-$L(X))_X
. E S X="<Missing>"
. W ?50,X
. S X=$S(LR61:$E($$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR"),1,14),1:" ")
. W ?70,$S(X'="":X,1:"<Missing>")
. W !,?30,$P(LR64(0),"^")
. W ?50,$S(LR62:$P(^LAB(62,LR62,0),"^"),'LR61:"",1:"<Missing>")
. S X=$S(LR642:$P($G(^LAB(64.2,LR642,0)),"^",2),1:"")
. W ?70,$S(X'="":X,1:"No Mapping"),!
. I LR64<1 W ?3,"Warning - test does not have NATIONAL VA LAB CODE assigned.",!
;
I LA7EXIT D CLEAN Q
I ($Y+6)>IOSL D HDR
I LA7EXIT D CLEAN Q
D SH2
S I=0
F S I=$O(^LAB(62.4,LA7624,3,I)) Q:'I D Q:LA7EXIT
. I ($Y+6)>IOSL D HDR Q:LA7EXIT D SH2 Q:LA7EXIT
. S X=^LAB(62.4,LA7624,3,I,0),X(2)=$G(^LAB(62.4,LA7624,3,I,2))
. S LR60=+X,LR61=$P(X(2),"^",13)
. W !,$J(I,2),?3,$E($P(^LAB(60,LR60,0),"^"),1,25)
. S LA7CODE=$P(X,"^",6)
. W ?30,$S(LA7CODE'="":LA7CODE,1:"<Missing>")
. I LR61 S X=$P(^LAB(61,LR61,0),"^")_"("_LR61_")"
. E S X="<Missing>"
. W ?55,X
. S X="("_$P($$GET1^DIQ(60,LR60_",",5),";",2)_")"
. W !,?3,$E($$GET1^DIQ(60,LR60_",",400),1,25-$L(X))_X
. I LA7CODE?5N1"."4N D
. . S Y=$O(^LAM("C",LA7CODE_" ",0))
. . I Y W ?30,$E($P(^LAM(Y,0),"^"),1,20)
. S X=$S(LR61:$E($$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR"),1,14),1:" ")
. W ?55,$S(X'="":X,1:"<Missing>"),!
. S LR64=+$P($G(^LAB(60,LR60,64)),"^",2),LR64(0)=$G(^LAM(LR64,0))
. I LR64<1 W ?3,"Warning - test does not have RESULT NLT CODE assigned.",!
. I LR64>0,$P(LR64(0),"^",2)'=LA7CODE W ?3,"Warning - RESULT NLT CODE does not match UI TEST CODE."
;
I '$D(ZTQUEUED),'LA7EXIT,$E(IOST,1,2)="C-" D TERM
D CLEAN
Q
;
;
CLEAN ; Clean up and quit
I $E(IOST,1,2)'="C-" W @IOF
I '$D(ZTQUEUED) D ^%ZISC
E S ZTREQ="@"
Q
;
;
HDR ; Header for test code mapping
I '$D(ZTQUEUED),LA7PAGE,$E(IOST,1,2)="C-" D TERM Q:$G(LA7EXIT)
W @IOF S $X=0
S LA7PAGE=LA7PAGE+1
W !,"Point of Care Test Code Mapping",?IOM-20," Page: ",LA7PAGE
W !," for interface: ",$P(LA7624(0),"^"),?IOM-23," Printed: ",LA7NOW
W !,LA7LINE,!
Q
;
;
SH1 ; Sub header #1
W !,"POC Order Test Codes using Load/Work List: ",$P(^LRO(68.2,LRLL,0),"^")
W !,"# Lab Test",?30,"Order NLT Code",?50,"Specimen(IEN)",?70,"HL7 Spec"
W !,?30,"Order NLT Name",?50,"Collection Sample",?70,"WKLD Code"
W !,LA7LINE2,!
Q
;
;
SH2 ; Sub head #2
W !,"POC Result Test Codes using Auto Instrument: ",$P(LA7624(0),"^")
W !,"# Lab Test",?30,"Result NLT Code",?55,"Specimen(IEN)"
W !," Dataname(IEN)",?30,"Result NLT Name",?55,"HL7 Spec"
W !,LA7LINE2,!
Q
;
;
TERM ;
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="E" D ^DIR S:$D(DIRUT) LA7EXIT=1
Q
LA7PCFG ;VA/DALOI/JMC - Configrure Lab Point of Care Interface; Jan 12, 2004
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**1031**;NOV 01, 1997
+2 ;
+3 ;;VA LA Patche(s): 67
+4 ;
+5 ; Reference to DIV4^XUSER supported by DBIA #2533
+6 QUIT
+7 ;
EN ; Configure files #62.48, #62.4 and #68.2
+1 NEW DIR,DIROUT,DIRUT,DUOUT,LA7QUIT,LRLL,X,Y
+2 SET LRLL=0
+3 FOR
Begin DoDot:1
+4 SET DIR(0)="SO^1:LA7 MESSAGE PARAMETER (#62.48);2:LOAD/WORK LIST (#68.2);3:AUTO INSTRUMENT (#62.4);4:Print POC Test Code Mapping"
+5 SET DIR("A")="Select which file to setup"
+6 DO ^DIR
+7 IF $DATA(DIRUT)
QUIT
+8 IF Y=1
DO E6248
QUIT
+9 IF Y=2
DO E682
QUIT
+10 IF Y=3
DO E624
QUIT
+11 IF Y=4
DO PRINT
QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+12 QUIT
+13 ;
+14 ;
E6248 ; Setup/edit file #62.48
+1 ;
+2 NEW DA,DIC,DIE,DIR,DIRUT,DR,DTOUT,DUOUT,LA76248,LA7TYP,X,Y
+3 DO EN^DDIOL("","","!!")
+4 SET DIC="^LAHM(62.48,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $P(^(0),U,9)=20!($P(^(0),U,9)=21)"
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET (DA,LA76248)=+Y
+8 LOCK +^LAHM(62.48,LA76248):0
+9 IF '$TEST
DO EN^DDIOL("Another user is editing this entry.","","!?5")
QUIT
+10 DO EN^DDIOL("","","!!")
+11 SET DIR(0)="YO"
+12 SET DIR("A")="Does this POC interface want to receive VistA ADT messages"
+13 SET DIR("B")=$SELECT($PIECE($GET(^LAHM(62.48,LA76248,0)),"^",9)=21:"YES",1:"NO")
+14 DO ^DIR
+15 IF $DATA(DIRUT)
QUIT
+16 SET LA7TYP=$SELECT(Y=1:21,1:20)
+17 IF LA7TYP=21
Begin DoDot:1
+18 DO EN^DDIOL("Remember to add the LA7POC ADT RTR event protocol to the appropriate","","!!")
+19 DO EN^DDIOL("ADT event protocols as specified in the Lab POC User Guide","","!")
+20 DO EN^DDIOL("","","!!")
End DoDot:1
+21 SET DIE=DIC
SET DR="11///"_LA7TYP_";2;3;4///ON;20"
+22 DO ^DIE
+23 LOCK -^LAHM(62.48,LA76248)
+24 QUIT
+25 ;
+26 ;
E624 ; Setup/edit file #62.4
+1 ;
+2 NEW DA,DIC,DIE,DR,LA7624,LA76248,LA7ERR,LRNLT,LRX,LRY,X,Y
+3 ;
+4 DO EN^DDIOL("","","!")
+5 SET DIC="^LAB(62.4,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $E($P(^(0),U),1,6)=""LA7POC"""
+6 DO ^DIC
+7 IF Y<1
QUIT
+8 SET (DA,LA7624)=+Y
+9 LOCK +^LAB(62.4,LA7624):0
+10 IF '$TEST
DO EN^DDIOL("Another user is editing this entry.","","!?5")
QUIT
+11 SET DIE=DIC
+12 SET DR="3"_$SELECT(LRLL>0:"//"_$$GET1^DIQ(68.2,LRLL_",",.01),1:"")_";8;10;11;12////0;18;30;107"
+13 SET DR(2,62.41)=".01;S LRNLT=$$GET1^DIQ(64,+$P($G(^LAB(60,X,64)),U,2)_"","",1);2;6////^S X=LRNLT;8R;12;13;14;17;18;19;21//YES"
+14 DO ^DIE
+15 ;
+16 ; Check if loadlist type = POC
+17 IF $PIECE(^LAB(62.4,LA7624,0),"^",4)
Begin DoDot:1
+18 SET LRLL=$PIECE(^LAB(62.4,LA7624,0),"^",4)
+19 IF $PIECE(^LRO(68.2,LRLL,0),"^",3)'=2
DO EN^DDIOL("**WARNING-Associated Load/Work List "_$$GET1^DIQ(68.2,LRLL_",",.01)_" is not TYPE: POINT OF CARE**","","!?2")
End DoDot:1
+20 ;
+21 ; Check if 62.4 name matches 62.48 name
+22 IF $PIECE(^LAB(62.4,LA7624,0),"^",8)
Begin DoDot:1
+23 SET LRX=$$GET1^DIQ(62.48,$PIECE(^LAB(62.4,LA7624,0),"^",8)_",",.01)
+24 SET LRY=$$GET1^DIQ(62.4,LA7624_",",.01)
+25 IF LRX'=LRY
DO EN^DDIOL("**WARNING-Name of entry in AUTO INSTRUMENT file should match name of MESSAGE CONFIGURATION**","","!?2")
End DoDot:1
+26 ;
+27 LOCK -^LAB(62.4,LA7624)
+28 QUIT
+29 ;
+30 ;
E682 ; Setup/edit file #68.2
+1 NEW DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DUOUT,I
+2 NEW LA7ERR,LR60,LR61,LRAA,LRDIV,LRMSG,LRPROF,LRX,LRY,X,Y
+3 ;
+4 DO EN^DDIOL("","","!")
+5 SET DIC="^LRO(68.2,"
SET DIC(0)="AELMQ"
+6 IF LRLL>0
SET DIC("B")=$$GET1^DIQ(68.2,LRLL_",",.01)
+7 DO ^DIC
+8 IF Y<1
QUIT
+9 SET (DA,LRLL)=+Y
+10 LOCK +^LRO(68.2,LRLL):0
+11 IF '$TEST
DO EN^DDIOL("Another user is editing this entry.","","!?5")
QUIT
+12 SET DIE=DIC
+13 SET DR=".01;.02///UNIVERSAL;.03///2;.08///ACCESSION;.14;1;1.5;1.7;50"
+14 SET DR(2,68.23)=".01;2;2.2;1"
+15 SET DR(3,68.24)=".01;I ""IB""'[$P(^LAB(60,X,0),""^"",3) S Y=2;1R;3;4;2///NO"
+16 DO ^DIE
+17 LOCK -^LRO(68.2,LRLL)
+18 WRITE !
+19 ;
+20 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
+21 IF LRPROF<1
Begin DoDot:1
+22 DO EN^DDIOL($CHAR(7)_"*** Need at least one profile for POC interface ***","","!!")
End DoDot:1
QUIT
+23 ;
+24 IF $ORDER(^LRO(68.2,LRLL,10,LRPROF))
Begin DoDot:1
+25 DO EN^DDIOL($CHAR(7)_"*** Only one profile should exist for POC interface ***","","!!")
End DoDot:1
QUIT
+26 ;
+27 SET LRAA=$PIECE($GET(^LRO(68.2,LRLL,10,LRPROF,0)),U,2)
+28 IF 'LRAA
QUIT
+29 ;
+30 ; Check tests on profile for specimen/collection sample
+31 SET I=0
+32 FOR
SET I=$ORDER(^LRO(68.2,LRLL,10,LRPROF,1,I))
IF 'I
QUIT
Begin DoDot:1
+33 SET LRX=$GET(^LRO(68.2,LRLL,10,LRPROF,1,I,0))
+34 SET LR60=$PIECE(LRX,"^")
SET LR61=$PIECE(LRX,"^",2)
+35 SET LR60(0)=^LAB(60,LR60,0)
+36 IF "IB"[$PIECE(LR60(0),"^",3)
Begin DoDot:2
+37 IF 'LR61
Begin DoDot:3
+38 SET LRMSG(I)=$PIECE(LR60(0),"^")_" missing specimen"
End DoDot:3
QUIT
+39 IF '$PIECE(LRX,"^",5)
Begin DoDot:3
+40 SET LRMSG(I)=$PIECE(LR60(0),"^")_" missing collection sample for specimen "_$PIECE(^LAB(61,LR61,0),"^")
End DoDot:3
End DoDot:2
End DoDot:1
+41 IF $DATA(LRMSG)
DO EN^DDIOL(.LRMSG,"","")
+42 ;
+43 DO EN^DDIOL("Now edit the associated division for accession area "_$$GET1^DIQ(68,LRAA_",",.01)_".","","!!")
+44 SET DA=LRAA
SET DIE="^LRO(68,"
SET DR=".091"
+45 DO ^DIE
+46 ;
+47 SET LRDIV=$ORDER(^LRO(68,LRAA,3,0))
+48 IF 'LRDIV
Begin DoDot:1
+49 DO EN^DDIOL("*** A division needs to be associated with this POC accession area ***","","!!")
End DoDot:1
QUIT
+50 ;
+51 IF $ORDER(^LRO(68,LRAA,3,LRDIV))
Begin DoDot:1
+52 DO EN^DDIOL($CHAR(7)_"*** Lab POC software will use "_$PIECE($$NS^XUAF4(LRDIV),"^"),"","!!")
+53 DO EN^DDIOL("as the default division with this accession area ***","","!?4")
End DoDot:1
+54 ;
+55 SET LRX=$$FIND1^DIC(200,"","OX","LRLAB,POC","B","")
+56 IF LRX<1
DO EN^DDIOL($CHAR(7)_"*** Unable to identify user 'LRLAB,POC' in NEW PERSON file ***","","!!")
+57 IF LRX>0
Begin DoDot:1
+58 KILL LRY
+59 SET LRY=$$DIV4^XUSER(.LRY,LRX)
+60 IF $DATA(LRY(LRDIV))
QUIT
+61 DO EN^DDIOL($CHAR(7)_"*** Have IRM assign division "_$PIECE($$NS^XUAF4(LRDIV),"^")_" to user 'LRLAB,POC' ***","","!!")
End DoDot:1
+62 QUIT
+63 ;
+64 ;
PRINT ; Print test code mappings for POC setup
+1 NEW %ZIS,DIC,LA7624,ZTDTH,ZTSK,ZTRTN,ZTIO,ZTSAVE,X,Y
+2 ;
+3 DO EN^DDIOL("","","!")
+4 SET DIC="^LAB(62.4,"
SET DIC(0)="AEMQ"
SET DIC("S")="I $E($P(^(0),U),1,6)=""LA7POC"""
+5 DO ^DIC
+6 IF Y<1
QUIT
+7 SET LA7624=+Y
+8 ;
+9 SET %ZIS="MQ"
DO ^%ZIS
+10 IF POP
DO HOME^%ZIS
QUIT
+11 IF $DATA(IO("Q"))
Begin DoDot:1
+12 SET ZTRTN="DQP^LA7PCFG"
SET ZTSAVE("LA7624")=""
SET ZTDESC="Print POC Setup"
+13 DO ^%ZTLOAD
DO ^%ZISC
+14 DO EN^DDIOL("Request "_$SELECT($GET(ZTSK):"queued - Task #"_ZTSK,1:"NOT queued"),"","!")
End DoDot:1
QUIT
+15 ;
DQP ; entry point from above and TaskMan
+1 ;
+2 NEW I,X,Y
+3 NEW LA7EXIT,LA7INTYP,LA7LINE,LA7LINE2,LA7NOW,LA7PAGE,LA7CODE
+4 NEW LA76248,LR60,LR61,LR62,LR64,LR642,LRLL,LRPROF
+5 SET LA7NOW=$$HTE^XLFDT($HOROLOG,"1D")
SET (LA7EXIT,LA7PAGE)=0
+6 SET LA7624(0)=$GET(^LAB(62.4,LA7624,0))
+7 SET LA76248=$PIECE(LA7624(0),"^",8)
+8 SET LA7INTYP=$PIECE(^LAHM(62.48,LA76248,0),"^",9)
+9 SET LRLL=$PIECE(LA7624(0),"^",4)
+10 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
+11 SET LA7LINE=$$REPEAT^XLFSTR("=",IOM)
+12 SET LA7LINE2=$$REPEAT^XLFSTR("-",IOM)
+13 DO HDR
+14 WRITE !!,"VistA ADT feed enabled: ",$SELECT(LA7INTYP=21:"YES",LA7INTYP=20:"NO",1:"UNKNOWN"),!!
+15 DO SH1
+16 ;
+17 SET I=0
+18 FOR
SET I=$ORDER(^LRO(68.2,LRLL,10,LRPROF,1,I))
IF 'I
QUIT
Begin DoDot:1
+19 IF ($Y+6)>IOSL
DO HDR
IF LA7EXIT
QUIT
DO SH1
IF LA7EXIT
QUIT
+20 SET X=^LRO(68.2,LRLL,10,LRPROF,1,I,0)
+21 SET LR60=+X
SET LR64=+$GET(^LAB(60,LR60,64))
SET LR64(0)=$GET(^LAM(LR64,0))
+22 SET LR61=$PIECE(X,"^",2)
SET LR642=$PIECE(X,"^",4)
SET LR62=0
+23 IF LR61
SET LR62=$PIECE(X,"^",5)
+24 IF 'LR62
IF LR61
SET LR62=$$GET1^DIQ(61,LR61_",",4.1,"I")
+25 WRITE !,$JUSTIFY(I,2),?3,$EXTRACT($PIECE(^LAB(60,LR60,0),"^"),1,25)
+26 SET X=$PIECE(LR64(0),"^",2)
+27 WRITE ?30,$SELECT(X'="":X,1:"<Missing>")
+28 IF LR61
Begin DoDot:2
+29 SET X="("_LR61_")"
+30 SET X=$EXTRACT($PIECE(^LAB(61,LR61,0),"^"),1,19-$LENGTH(X))_X
End DoDot:2
+31 IF '$TEST
SET X="<Missing>"
+32 WRITE ?50,X
+33 SET X=$SELECT(LR61:$EXTRACT($$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR"),1,14),1:" ")
+34 WRITE ?70,$SELECT(X'="":X,1:"<Missing>")
+35 WRITE !,?30,$PIECE(LR64(0),"^")
+36 WRITE ?50,$SELECT(LR62:$PIECE(^LAB(62,LR62,0),"^"),'LR61:"",1:"<Missing>")
+37 SET X=$SELECT(LR642:$PIECE($GET(^LAB(64.2,LR642,0)),"^",2),1:"")
+38 WRITE ?70,$SELECT(X'="":X,1:"No Mapping"),!
+39 IF LR64<1
WRITE ?3,"Warning - test does not have NATIONAL VA LAB CODE assigned.",!
End DoDot:1
IF LA7EXIT
QUIT
+40 ;
+41 IF LA7EXIT
DO CLEAN
QUIT
+42 IF ($Y+6)>IOSL
DO HDR
+43 IF LA7EXIT
DO CLEAN
QUIT
+44 DO SH2
+45 SET I=0
+46 FOR
SET I=$ORDER(^LAB(62.4,LA7624,3,I))
IF 'I
QUIT
Begin DoDot:1
+47 IF ($Y+6)>IOSL
DO HDR
IF LA7EXIT
QUIT
DO SH2
IF LA7EXIT
QUIT
+48 SET X=^LAB(62.4,LA7624,3,I,0)
SET X(2)=$GET(^LAB(62.4,LA7624,3,I,2))
+49 SET LR60=+X
SET LR61=$PIECE(X(2),"^",13)
+50 WRITE !,$JUSTIFY(I,2),?3,$EXTRACT($PIECE(^LAB(60,LR60,0),"^"),1,25)
+51 SET LA7CODE=$PIECE(X,"^",6)
+52 WRITE ?30,$SELECT(LA7CODE'="":LA7CODE,1:"<Missing>")
+53 IF LR61
SET X=$PIECE(^LAB(61,LR61,0),"^")_"("_LR61_")"
+54 IF '$TEST
SET X="<Missing>"
+55 WRITE ?55,X
+56 SET X="("_$PIECE($$GET1^DIQ(60,LR60_",",5),";",2)_")"
+57 WRITE !,?3,$EXTRACT($$GET1^DIQ(60,LR60_",",400),1,25-$LENGTH(X))_X
+58 IF LA7CODE?5N1"."4N
Begin DoDot:2
+59 SET Y=$ORDER(^LAM("C",LA7CODE_" ",0))
+60 IF Y
WRITE ?30,$EXTRACT($PIECE(^LAM(Y,0),"^"),1,20)
End DoDot:2
+61 SET X=$SELECT(LR61:$EXTRACT($$GET1^DIQ(61,LR61_",","LEDI HL7:HL7 ABBR"),1,14),1:" ")
+62 WRITE ?55,$SELECT(X'="":X,1:"<Missing>"),!
+63 SET LR64=+$PIECE($GET(^LAB(60,LR60,64)),"^",2)
SET LR64(0)=$GET(^LAM(LR64,0))
+64 IF LR64<1
WRITE ?3,"Warning - test does not have RESULT NLT CODE assigned.",!
+65 IF LR64>0
IF $PIECE(LR64(0),"^",2)'=LA7CODE
WRITE ?3,"Warning - RESULT NLT CODE does not match UI TEST CODE."
End DoDot:1
IF LA7EXIT
QUIT
+66 ;
+67 IF '$DATA(ZTQUEUED)
IF 'LA7EXIT
IF $EXTRACT(IOST,1,2)="C-"
DO TERM
+68 DO CLEAN
+69 QUIT
+70 ;
+71 ;
CLEAN ; Clean up and quit
+1 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
+2 IF '$DATA(ZTQUEUED)
DO ^%ZISC
+3 IF '$TEST
SET ZTREQ="@"
+4 QUIT
+5 ;
+6 ;
HDR ; Header for test code mapping
+1 IF '$DATA(ZTQUEUED)
IF LA7PAGE
IF $EXTRACT(IOST,1,2)="C-"
DO TERM
IF $GET(LA7EXIT)
QUIT
+2 WRITE @IOF
SET $X=0
+3 SET LA7PAGE=LA7PAGE+1
+4 WRITE !,"Point of Care Test Code Mapping",?IOM-20," Page: ",LA7PAGE
+5 WRITE !," for interface: ",$PIECE(LA7624(0),"^"),?IOM-23," Printed: ",LA7NOW
+6 WRITE !,LA7LINE,!
+7 QUIT
+8 ;
+9 ;
SH1 ; Sub header #1
+1 WRITE !,"POC Order Test Codes using Load/Work List: ",$PIECE(^LRO(68.2,LRLL,0),"^")
+2 WRITE !,"# Lab Test",?30,"Order NLT Code",?50,"Specimen(IEN)",?70,"HL7 Spec"
+3 WRITE !,?30,"Order NLT Name",?50,"Collection Sample",?70,"WKLD Code"
+4 WRITE !,LA7LINE2,!
+5 QUIT
+6 ;
+7 ;
SH2 ; Sub head #2
+1 WRITE !,"POC Result Test Codes using Auto Instrument: ",$PIECE(LA7624(0),"^")
+2 WRITE !,"# Lab Test",?30,"Result NLT Code",?55,"Specimen(IEN)"
+3 WRITE !," Dataname(IEN)",?30,"Result NLT Name",?55,"HL7 Spec"
+4 WRITE !,LA7LINE2,!
+5 QUIT
+6 ;
+7 ;
TERM ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+2 SET DIR(0)="E"
DO ^DIR
IF $DATA(DIRUT)
SET LA7EXIT=1
+3 QUIT
