LA7SCE ;DALOI/JMC - Shipping Configuration Utility ;05/13/10 15:41
;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61,64,74**;Sep 27, 1994;Build 229
;
; ZEXCEPT is used to identify variables which are external to a specific TAG
; used in conjunction with Eclipse M-editor.
;
Q
;
;
SCFE ; Edit file #62.9, Shipping Configuration.
;
N DA,DIE,DIC,DIR,DLAYGO,DIRUT,DR,DTOUT,DIROUT,X,Y
N LA7CHECK,LA7COPY,LA7NVAF,LA7SCFG,LA7SCFR,LA7TYPE,LA7VAF,LA7X,LR62,LRSS
;
S DIC="^LAHM(62.9,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING CONFIGURATION: "
S DIC("DR")=".02;.03",DLAYGO=62.9
D ^DIC
K DA,DIC,DIE,DR
I Y<1 Q
;
S LA7SCFG=+Y,LA7SCFG(0)=Y(0)
;
D LOCK^DILF("^LAHM(62.9,LA7SCFG)")
I '$T D Q
. D EN^DDIOL("Unable to obtain lock on entry "_$P(LA7SCFG(0),"^"),"","!?3")
;
; LA7TYPE=1 editing as collecting facility
; LA7TYPE=2 editing as host facility
S DIR(0)="SO^1:Collecting facility;2:Host facility",DIR("A")="Are you editing this entry as the"
S DIR("?",1)="Is this entry used by the Collecting facility to ship specimens,"
S DIR("?",2)="or by the Host facility to accept a shipment."
S DIR("?")="This determines which fields are edited in the file."
D ^DIR
I $D(DIRUT) D UNL629 Q
S LA7TYPE=+Y
;
; Determine if other facility is non-VA.
; When acting as collecting facility is host non-VA
; When acting as host is collecting facility non-VA
S LA7VAF="",LA7VAF(1)=0,LA7NVAF=0
I $P(LA7SCFG(0),"^",2),$P(LA7SCFG(0),"^",3) D
. S LA7X=$S(LA7TYPE=1:$P(LA7SCFG(0),"^",3),1:$P(LA7SCFG(0),"^",2))
. S LA7VAF=$$GET1^DIQ(4,LA7X_",","AGENCY CODE","I")
. S LA7NVAF=$$NVAF^LA7VHLU2(LA7X)
. I LA7TYPE=1,$E($$ID^XUAF4("VASTANUM",$P(LA7SCFG(0),"^",3)),1,5)="200LR" S LA7VAF(1)=1
I LA7VAF="" D Q
. N LA7ERR,LA7MSG,LA7X,LA7Y
. S LA7MSG="Unable to proceed - institution "
. S LA7Y=$S(LA7TYPE=1:$P(LA7SCFG(0),"^",3),1:$P(LA7SCFG(0),"^",2))
. S LA7X=$$GET1^DIQ(4,LA7Y_",",.01,"","","LA7ERR")
. I LA7X="" S LA7MSG=LA7MSG_"IEN #"_LA7Y_" - "_$G(LA7ERR("DIERR",1,"TEXT",1))
. E S LA7MSG=LA7MSG_LA7X_" missing AGENCY CODE field in INSTITUTION file (#4)"
. D EN^DDIOL(LA7MSG,"","!!?3")
. D UNL629
;
; If acting as host ask if user wants to copy test config from another entry.
I LA7TYPE=2 D
. N DIC,Y
. S LA7COPY=$$ASKCOPY
. I LA7COPY<1 Q
. S LA7CHECK=$$CHECK(LA7SCFG)
. I LA7CHECK<1 S LA7COPY=LA7CHECK Q
. I LA7COPY<1 Q
. I LA7COPY=1 D Q
. . S DIC="^LAHM(62.9,",DIC(0)="AEMQZ",DIC("A")="Select SHIPPING CONFIGURATION to COPY FROM: ",DIC("S")="I Y'=LA7SCFG"
. . D ^DIC K DIC("S")
. . I Y<1 Q
. . S LA7SCFR=+Y,LA7SCFR(0)=Y(0)
. . D CLRSCT(.LA7SCFG)
. . D COPYSC(.LA7SCFR,.LA7SCFG)
. I LA7COPY=2 D Q
. . D CLRSCT(.LA7SCFG)
. . D COPY60(.LA7SCFG)
I LA7TYPE=2,LA7COPY<0 D UNL629 Q
K DA,DIE,DIC,DIR,DLAYGO,DIRUT,DR,DTOUT,DIROUT,X,Y
;
; Set up DR string when acting as collecting facility
I LA7TYPE=1 D
. S DR=".01;.02;.06;.03;.031;"
. I LA7NVAF>1 S DR=DR_".11;.12;.14;.15;"
. I LA7NVAF=1 S DR=DR_".14////1;.15////1;"
. I LA7VAF="V",LA7VAF(1)=1 S DR=DR_".14;"
. S DR=DR_".04;.07;.08;.09;.1;.13;44;60"
. S DR(2,62.9001)=".01;S LRSS=$P(^LAB(60,X,0),U,4);.02;.025;.026;.03;.04;.05;.06;.07"
;
; Set up DR string when acting as host facility
I LA7TYPE=2 D
. S DR=".01;.02;.06;.03;.031;"
. I LA7NVAF>1 S DR=DR_".11;.14;.15;"
. I LA7NVAF=1 S DR=DR_".14////0;.15////1;"
. S DR=DR_".04;.05;60"
. S DR(2,62.9001)=".01;S LRSS=$P(^LAB(60,X,0),U,4);.04;.09;S LR62=X D HLP62^LA7SMU1(LR62);.03;I LR62,$P(^LAB(62,LR62,0),U,2)'="""" S Y=""@2"";5.7;5.9"_$S(LA7NVAF=0:"////99VA62",1:"")_";@2"
;
; Determine if non-VA test codes/specimen fields should be asked
I LA7VAF'="V"!(LA7VAF="V"&(LA7VAF(1)=1)) D
. S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7SCFG,0),U,15)'=1 S Y=""@9"";5.1;5.2;5.5"
. I LA7TYPE=1,LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99LST"
. I LA7TYPE=1,LA7VAF="V",LA7VAF(1)=1 S DR(2,62.9001)=DR(2,62.9001)_"//L"
. S DR(2,62.9001)=DR(2,62.9001)_";@9"
. I LA7TYPE=1 D
. . S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7SCFG,0),U,16)'=1 S Y=""@10"";5.3;5.4;5.6"
. . I LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99LRP;5.7;5.8;5.9////99LRS"
. . S DR(2,62.9001)=DR(2,62.9001)_";@10"
. I LA7TYPE=2 D
. . S DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7SCFG,0),U,16)'=1 S Y=""@10"";5.3;5.4;5.6"
. . I LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99LRP"
. . S DR(2,62.9001)=DR(2,62.9001)_";@10"
;
I LA7TYPE=1 D
. N J,K
. S DR(2,62.9001)=DR(2,62.9001)_";"
. S X="1.1;I 'X S Y=1.2;1.15;1.16;1.2;I 'X S Y=2.1;1.25;1.26;2.1;I '+X S Y=2.3;2.15;2.16;2.3;I '+X S Y=2.2;2.35;2.36;2.2;I '+X S Y=""@12"";2.25;2.26;@12"
. I ($L(DR(2,62.9001))+$L(X))<246 S DR(2,62.9001)=DR(2,62.9001)_X Q
. S K=$L(X,";")
. F J=1:1:K D
. . I ($L(DR(2,62.9001))+$L($P(X,";")))>244 S J=K Q
. . S DR(2,62.9001)=DR(2,62.9001)_$P(X,";")_";",X=$P(X,";",2,K)
. I X'="" S DR(2,62.9001,1)=X
;
S DA=LA7SCFG,DIE="^LAHM(62.9,"
D ^DIE,UNL629
Q
;
;
; Unlock entry in 62.9
UNL629 ;
;
;ZEXCEPT: LA7SCFG
;
L -^LAHM(62.9,LA7SCFG)
;
Q
;
;
SCTE ; Edit file #62.91, Shipping Container.
N DA,DIE,DIC,DLAYGO,DR,X,Y
S DIC="^LAHM(62.91,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING CONTAINER: ",DLAYGO=62.91
D ^DIC
I Y<1 Q
S DA=+Y,DIE=DIC,DR=".01;.02"
D ^DIE
Q
;
;
SCME ; Edit file #62.92, Shipping Method.
N DA,DIE,DIC,DLAYGO,DR,X,Y
S DIC="^LAHM(62.92,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING METHOD: ",DLAYGO=62.92
D ^DIC
I Y<1 Q
S DA=+Y,DIE=DIC,DR=".01;.02"
D ^DIE
Q
;
;
SCDE ; Edit file #62.93, Shipping Condition.
N DA,DIE,DIC,DLAYGO,DR,X,Y
S DIC="^LAHM(62.93,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING CONDITION: ",DLAYGO=62.93
D ^DIC
I Y<1 Q
S DA=+Y,DIE=DIC,DR=".01;.02"
D ^DIE
Q
;
;
ASKCOPY() ; Ask if user want to copy tests from file #60 or another configuration in file #62.9 LAB SHIPPING CONFIGURATION
; Returns LA7COPY = -1 user quit/aborted
; = 0 do not copy
; = 1 use file #60
; = 2 use another entry in #62.49
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SMO^0:Do NOT copy;1:Another Shipping Configuration;2:Test Catalog - LABORATORY TEST File #60"
S DIR("A")="Copy a test profile from",DIR("B")="Do NOT copy"
S DIR("?",1)="If you want to duplicate a shipping configuration using another configuration"
S DIR("?",2)="or build from the tests marked as catalog tests in the LABORATORY TEST file."
S DIR("?")="Select the appropriate option."
D ^DIR
I $D(DIRUT) S Y=-1
Q Y
;
;
CHECK(LA7SCFG) ; Check if test exists for configuration and warn if overwriting
; Call with LA7SCFG = shipping configuration ien
; Returns -1 = user aborted/timeout
; 0 = no - don't overwrite
; 1 = yes - overwrite
I '$O(^LAHM(62.9,LA7SCFG,60,0)) Q 1
N DIR,DIRUT,DTOUT,DUOUT,X,Y
S DIR(0)="SBO^0:NO;1:YES"
S DIR("A",1)="Tests already exist for this configuration!",DIR("A")="Are you sure",DIR("B")="NO"
D ^DIR
I $D(DIRUT) S Y=-1
Q Y
;
;
COPYSC(LA7FR,LA7TO) ; Copy one shipping configuration to another
; Call with LA7FR = shipping configuration to copy FROM.
; LA7TO = shipping configuration ien to copy TO.
;
N LA760,LA762,LA76205,LA7X
;
W !!,"Copying tests from configuration: ",$P(LA7FR(0),"^")," to ",$P(LA7TO(0),"^"),!
S LA7X=0
F S LA7X=$O(^LAHM(62.9,LA7FR,60,LA7X)) Q:'LA7X D
. S LA760=$P($G(^LAHM(62.9,LA7FR,60,LA7X,0)),"^") ; file #60 laboratory test ien.
. S LA76205=$P($G(^LAHM(62.9,LA7FR,60,LA7X,0)),"^",4) ; file #62.05, urgency ien.
. S LA762=$P($G(^LAHM(62.9,LA7FR,60,LA7X,0)),"^",9) ; file #62, collection sample ien.
. I LA760 D FDA629(LA7TO,LA760,LA762,LA76205)
Q
;
;
COPY60(LA7SCFG) ; Copy catalog tests from file #60 to shipping configuration.
; Call with LA7SCFG = shipping configuration ien to add tests to from file #60
N LA760,LA762,LA7X
W !!,"Copying tests from file #60 LABORATORY TEST to ",$P(LA7SCFG(0),"^"),!
S LA760=0 ; file #60 pointer
I '$D(^LAHM(62.9,LA7SCFG,60,0)) S ^LAHM(62.9,LA7SCFG,60,0)="^62.9001P^0^0" ; set subfile zeroth node
F S LA760=$O(^LAB(60,LA760)) Q:'LA760 D
. I '$P($G(^LAB(60,LA760,64)),"^",3) Q ; Not a catalog item
. S LA7X=0
. F S LA7X=$O(^LAB(60,LA760,3,LA7X)) Q:'LA7X D
. . S LA762=+$G(^LAB(60,LA760,3,LA7X,0)) ; file #62 pointer (collection sample)
. . I LA762 D FDA629(LA7SCFG,LA760,LA762,"")
Q
;
;
FDA629(LA7SCFG,LA760,LA762,LA76205) ; Add entry to TEST/PROFILE multiple
; Call with LA7SCFG = file #62.9, shipping configuration ien
; LA760 = file #60, lab test ien
; LA762 = file #62, collection sample ien
; LA76205 = file #62.05 , urgency ien
N FDA,LA7DIE,LA7629
S LA7629(1)=LA7SCFG
S FDA(629,62.9001,"+2,"_+LA7SCFG_",",.01)=LA760
I LA76205 S FDA(629,62.9001,"+2,"_+LA7SCFG_",",.04)=LA76205
I LA762 S FDA(629,62.9001,"+2,"_+LA7SCFG_",",.09)=LA762
W:$X>(IOM-2) ! W "#"
D UPDATE^DIE("","FDA(629)","LA7629","LA7DIE(629)") ; Add test to shipping configuration.
Q
;
;
CLRSCT(LA7SCFG) ; Clear shipping configuration tests.
; Call with LA7SCFG = file #62.9, shipping configuration ien
N DA,DIK,LA7X
W !!,"Clearing existing tests from configuration: ",$P(LA7SCFG(0),"^"),!
S DA(1)=+LA7SCFG,DIK="^LAHM(62.9,"_DA(1)_",60,"
S LA7X=0
F S LA7X=$O(^LAHM(62.9,LA7SCFG,60,LA7X)) Q:'LA7X D
. W:$X>(IOM-2) ! W "*"
. S DA=LA7X D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLA7SCE 9495 printed Nov 22, 2024@16:49:36 Page 2
LA7SCE ;DALOI/JMC - Shipping Configuration Utility ;05/13/10 15:41
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61,64,74**;Sep 27, 1994;Build 229
+2 ;
+3 ; ZEXCEPT is used to identify variables which are external to a specific TAG
+4 ; used in conjunction with Eclipse M-editor.
+5 ;
+6 QUIT
+7 ;
+8 ;
SCFE ; Edit file #62.9, Shipping Configuration.
+1 ;
+2 NEW DA,DIE,DIC,DIR,DLAYGO,DIRUT,DR,DTOUT,DIROUT,X,Y
+3 NEW LA7CHECK,LA7COPY,LA7NVAF,LA7SCFG,LA7SCFR,LA7TYPE,LA7VAF,LA7X,LR62,LRSS
+4 ;
+5 SET DIC="^LAHM(62.9,"
SET DIC(0)="AELMQZ"
SET DIC("A")="Select SHIPPING CONFIGURATION: "
+6 SET DIC("DR")=".02;.03"
SET DLAYGO=62.9
+7 DO ^DIC
+8 KILL DA,DIC,DIE,DR
+9 IF Y<1
QUIT
+10 ;
+11 SET LA7SCFG=+Y
SET LA7SCFG(0)=Y(0)
+12 ;
+13 DO LOCK^DILF("^LAHM(62.9,LA7SCFG)")
+14 IF '$TEST
Begin DoDot:1
+15 DO EN^DDIOL("Unable to obtain lock on entry "_$PIECE(LA7SCFG(0),"^"),"","!?3")
End DoDot:1
QUIT
+16 ;
+17 ; LA7TYPE=1 editing as collecting facility
+18 ; LA7TYPE=2 editing as host facility
+19 SET DIR(0)="SO^1:Collecting facility;2:Host facility"
SET DIR("A")="Are you editing this entry as the"
+20 SET DIR("?",1)="Is this entry used by the Collecting facility to ship specimens,"
+21 SET DIR("?",2)="or by the Host facility to accept a shipment."
+22 SET DIR("?")="This determines which fields are edited in the file."
+23 DO ^DIR
+24 IF $DATA(DIRUT)
DO UNL629
QUIT
+25 SET LA7TYPE=+Y
+26 ;
+27 ; Determine if other facility is non-VA.
+28 ; When acting as collecting facility is host non-VA
+29 ; When acting as host is collecting facility non-VA
+30 SET LA7VAF=""
SET LA7VAF(1)=0
SET LA7NVAF=0
+31 IF $PIECE(LA7SCFG(0),"^",2)
IF $PIECE(LA7SCFG(0),"^",3)
Begin DoDot:1
+32 SET LA7X=$SELECT(LA7TYPE=1:$PIECE(LA7SCFG(0),"^",3),1:$PIECE(LA7SCFG(0),"^",2))
+33 SET LA7VAF=$$GET1^DIQ(4,LA7X_",","AGENCY CODE","I")
+34 SET LA7NVAF=$$NVAF^LA7VHLU2(LA7X)
+35 IF LA7TYPE=1
IF $EXTRACT($$ID^XUAF4("VASTANUM",$PIECE(LA7SCFG(0),"^",3)),1,5)="200LR"
SET LA7VAF(1)=1
End DoDot:1
+36 IF LA7VAF=""
Begin DoDot:1
+37 NEW LA7ERR,LA7MSG,LA7X,LA7Y
+38 SET LA7MSG="Unable to proceed - institution "
+39 SET LA7Y=$SELECT(LA7TYPE=1:$PIECE(LA7SCFG(0),"^",3),1:$PIECE(LA7SCFG(0),"^",2))
+40 SET LA7X=$$GET1^DIQ(4,LA7Y_",",.01,"","","LA7ERR")
+41 IF LA7X=""
SET LA7MSG=LA7MSG_"IEN #"_LA7Y_" - "_$GET(LA7ERR("DIERR",1,"TEXT",1))
+42 IF '$TEST
SET LA7MSG=LA7MSG_LA7X_" missing AGENCY CODE field in INSTITUTION file (#4)"
+43 DO EN^DDIOL(LA7MSG,"","!!?3")
+44 DO UNL629
End DoDot:1
QUIT
+45 ;
+46 ; If acting as host ask if user wants to copy test config from another entry.
+47 IF LA7TYPE=2
Begin DoDot:1
+48 NEW DIC,Y
+49 SET LA7COPY=$$ASKCOPY
+50 IF LA7COPY<1
QUIT
+51 SET LA7CHECK=$$CHECK(LA7SCFG)
+52 IF LA7CHECK<1
SET LA7COPY=LA7CHECK
QUIT
+53 IF LA7COPY<1
QUIT
+54 IF LA7COPY=1
Begin DoDot:2
+55 SET DIC="^LAHM(62.9,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Select SHIPPING CONFIGURATION to COPY FROM: "
SET DIC("S")="I Y'=LA7SCFG"
+56 DO ^DIC
KILL DIC("S")
+57 IF Y<1
QUIT
+58 SET LA7SCFR=+Y
SET LA7SCFR(0)=Y(0)
+59 DO CLRSCT(.LA7SCFG)
+60 DO COPYSC(.LA7SCFR,.LA7SCFG)
End DoDot:2
QUIT
+61 IF LA7COPY=2
Begin DoDot:2
+62 DO CLRSCT(.LA7SCFG)
+63 DO COPY60(.LA7SCFG)
End DoDot:2
QUIT
End DoDot:1
+64 IF LA7TYPE=2
IF LA7COPY<0
DO UNL629
QUIT
+65 KILL DA,DIE,DIC,DIR,DLAYGO,DIRUT,DR,DTOUT,DIROUT,X,Y
+66 ;
+67 ; Set up DR string when acting as collecting facility
+68 IF LA7TYPE=1
Begin DoDot:1
+69 SET DR=".01;.02;.06;.03;.031;"
+70 IF LA7NVAF>1
SET DR=DR_".11;.12;.14;.15;"
+71 IF LA7NVAF=1
SET DR=DR_".14////1;.15////1;"
+72 IF LA7VAF="V"
IF LA7VAF(1)=1
SET DR=DR_".14;"
+73 SET DR=DR_".04;.07;.08;.09;.1;.13;44;60"
+74 SET DR(2,62.9001)=".01;S LRSS=$P(^LAB(60,X,0),U,4);.02;.025;.026;.03;.04;.05;.06;.07"
End DoDot:1
+75 ;
+76 ; Set up DR string when acting as host facility
+77 IF LA7TYPE=2
Begin DoDot:1
+78 SET DR=".01;.02;.06;.03;.031;"
+79 IF LA7NVAF>1
SET DR=DR_".11;.14;.15;"
+80 IF LA7NVAF=1
SET DR=DR_".14////0;.15////1;"
+81 SET DR=DR_".04;.05;60"
+82 SET DR(2,62.9001)=".01;S LRSS=$P(^LAB(60,X,0),U,4);.04;.09;S LR62=X D HLP62^LA7SMU1(LR62);.03;I LR62,$P(^LAB(62,LR62,0),U,2)'="""" S Y=""@2"";5.7;5.9"_$SELECT(LA7NVAF=0:"////99VA62",1:"")_";@2"
End DoDot:1
+83 ;
+84 ; Determine if non-VA test codes/specimen fields should be asked
+85 IF LA7VAF'="V"!(LA7VAF="V"&(LA7VAF(1)=1))
Begin DoDot:1
+86 SET DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7SCFG,0),U,15)'=1 S Y=""@9"";5.1;5.2;5.5"
+87 IF LA7TYPE=1
IF LA7NVAF=1
SET DR(2,62.9001)=DR(2,62.9001)_"////99LST"
+88 IF LA7TYPE=1
IF LA7VAF="V"
IF LA7VAF(1)=1
SET DR(2,62.9001)=DR(2,62.9001)_"//L"
+89 SET DR(2,62.9001)=DR(2,62.9001)_";@9"
+90 IF LA7TYPE=1
Begin DoDot:2
+91 SET DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7SCFG,0),U,16)'=1 S Y=""@10"";5.3;5.4;5.6"
+92 IF LA7NVAF=1
SET DR(2,62.9001)=DR(2,62.9001)_"////99LRP;5.7;5.8;5.9////99LRS"
+93 SET DR(2,62.9001)=DR(2,62.9001)_";@10"
End DoDot:2
+94 IF LA7TYPE=2
Begin DoDot:2
+95 SET DR(2,62.9001)=DR(2,62.9001)_";I $P(^LAHM(62.9,LA7SCFG,0),U,16)'=1 S Y=""@10"";5.3;5.4;5.6"
+96 IF LA7NVAF=1
SET DR(2,62.9001)=DR(2,62.9001)_"////99LRP"
+97 SET DR(2,62.9001)=DR(2,62.9001)_";@10"
End DoDot:2
End DoDot:1
+98 ;
+99 IF LA7TYPE=1
Begin DoDot:1
+100 NEW J,K
+101 SET DR(2,62.9001)=DR(2,62.9001)_";"
+102 SET X="1.1;I 'X S Y=1.2;1.15;1.16;1.2;I 'X S Y=2.1;1.25;1.26;2.1;I '+X S Y=2.3;2.15;2.16;2.3;I '+X S Y=2.2;2.35;2.36;2.2;I '+X S Y=""@12"";2.25;2.26;@12"
+103 IF ($LENGTH(DR(2,62.9001))+$LENGTH(X))<246
SET DR(2,62.9001)=DR(2,62.9001)_X
QUIT
+104 SET K=$LENGTH(X,";")
+105 FOR J=1:1:K
Begin DoDot:2
+106 IF ($LENGTH(DR(2,62.9001))+$LENGTH($PIECE(X,";")))>244
SET J=K
QUIT
+107 SET DR(2,62.9001)=DR(2,62.9001)_$PIECE(X,";")_";"
SET X=$PIECE(X,";",2,K)
End DoDot:2
+108 IF X'=""
SET DR(2,62.9001,1)=X
End DoDot:1
+109 ;
+110 SET DA=LA7SCFG
SET DIE="^LAHM(62.9,"
+111 DO ^DIE
DO UNL629
+112 QUIT
+113 ;
+114 ;
+115 ; Unlock entry in 62.9
UNL629 ;
+1 ;
+2 ;ZEXCEPT: LA7SCFG
+3 ;
+4 LOCK -^LAHM(62.9,LA7SCFG)
+5 ;
+6 QUIT
+7 ;
+8 ;
SCTE ; Edit file #62.91, Shipping Container.
+1 NEW DA,DIE,DIC,DLAYGO,DR,X,Y
+2 SET DIC="^LAHM(62.91,"
SET DIC(0)="AELMQZ"
SET DIC("A")="Select SHIPPING CONTAINER: "
SET DLAYGO=62.91
+3 DO ^DIC
+4 IF Y<1
QUIT
+5 SET DA=+Y
SET DIE=DIC
SET DR=".01;.02"
+6 DO ^DIE
+7 QUIT
+8 ;
+9 ;
SCME ; Edit file #62.92, Shipping Method.
+1 NEW DA,DIE,DIC,DLAYGO,DR,X,Y
+2 SET DIC="^LAHM(62.92,"
SET DIC(0)="AELMQZ"
SET DIC("A")="Select SHIPPING METHOD: "
SET DLAYGO=62.92
+3 DO ^DIC
+4 IF Y<1
QUIT
+5 SET DA=+Y
SET DIE=DIC
SET DR=".01;.02"
+6 DO ^DIE
+7 QUIT
+8 ;
+9 ;
SCDE ; Edit file #62.93, Shipping Condition.
+1 NEW DA,DIE,DIC,DLAYGO,DR,X,Y
+2 SET DIC="^LAHM(62.93,"
SET DIC(0)="AELMQZ"
SET DIC("A")="Select SHIPPING CONDITION: "
SET DLAYGO=62.93
+3 DO ^DIC
+4 IF Y<1
QUIT
+5 SET DA=+Y
SET DIE=DIC
SET DR=".01;.02"
+6 DO ^DIE
+7 QUIT
+8 ;
+9 ;
ASKCOPY() ; Ask if user want to copy tests from file #60 or another configuration in file #62.9 LAB SHIPPING CONFIGURATION
+1 ; Returns LA7COPY = -1 user quit/aborted
+2 ; = 0 do not copy
+3 ; = 1 use file #60
+4 ; = 2 use another entry in #62.49
+5 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+6 SET DIR(0)="SMO^0:Do NOT copy;1:Another Shipping Configuration;2:Test Catalog - LABORATORY TEST File #60"
+7 SET DIR("A")="Copy a test profile from"
SET DIR("B")="Do NOT copy"
+8 SET DIR("?",1)="If you want to duplicate a shipping configuration using another configuration"
+9 SET DIR("?",2)="or build from the tests marked as catalog tests in the LABORATORY TEST file."
+10 SET DIR("?")="Select the appropriate option."
+11 DO ^DIR
+12 IF $DATA(DIRUT)
SET Y=-1
+13 QUIT Y
+14 ;
+15 ;
CHECK(LA7SCFG) ; Check if test exists for configuration and warn if overwriting
+1 ; Call with LA7SCFG = shipping configuration ien
+2 ; Returns -1 = user aborted/timeout
+3 ; 0 = no - don't overwrite
+4 ; 1 = yes - overwrite
+5 IF '$ORDER(^LAHM(62.9,LA7SCFG,60,0))
QUIT 1
+6 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
+7 SET DIR(0)="SBO^0:NO;1:YES"
+8 SET DIR("A",1)="Tests already exist for this configuration!"
SET DIR("A")="Are you sure"
SET DIR("B")="NO"
+9 DO ^DIR
+10 IF $DATA(DIRUT)
SET Y=-1
+11 QUIT Y
+12 ;
+13 ;
COPYSC(LA7FR,LA7TO) ; Copy one shipping configuration to another
+1 ; Call with LA7FR = shipping configuration to copy FROM.
+2 ; LA7TO = shipping configuration ien to copy TO.
+3 ;
+4 NEW LA760,LA762,LA76205,LA7X
+5 ;
+6 WRITE !!,"Copying tests from configuration: ",$PIECE(LA7FR(0),"^")," to ",$PIECE(LA7TO(0),"^"),!
+7 SET LA7X=0
+8 FOR
SET LA7X=$ORDER(^LAHM(62.9,LA7FR,60,LA7X))
if 'LA7X
QUIT
Begin DoDot:1
+9 ; file #60 laboratory test ien.
SET LA760=$PIECE($GET(^LAHM(62.9,LA7FR,60,LA7X,0)),"^")
+10 ; file #62.05, urgency ien.
SET LA76205=$PIECE($GET(^LAHM(62.9,LA7FR,60,LA7X,0)),"^",4)
+11 ; file #62, collection sample ien.
SET LA762=$PIECE($GET(^LAHM(62.9,LA7FR,60,LA7X,0)),"^",9)
+12 IF LA760
DO FDA629(LA7TO,LA760,LA762,LA76205)
End DoDot:1
+13 QUIT
+14 ;
+15 ;
COPY60(LA7SCFG) ; Copy catalog tests from file #60 to shipping configuration.
+1 ; Call with LA7SCFG = shipping configuration ien to add tests to from file #60
+2 NEW LA760,LA762,LA7X
+3 WRITE !!,"Copying tests from file #60 LABORATORY TEST to ",$PIECE(LA7SCFG(0),"^"),!
+4 ; file #60 pointer
SET LA760=0
+5 ; set subfile zeroth node
IF '$DATA(^LAHM(62.9,LA7SCFG,60,0))
SET ^LAHM(62.9,LA7SCFG,60,0)="^62.9001P^0^0"
+6 FOR
SET LA760=$ORDER(^LAB(60,LA760))
if 'LA760
QUIT
Begin DoDot:1
+7 ; Not a catalog item
IF '$PIECE($GET(^LAB(60,LA760,64)),"^",3)
QUIT
+8 SET LA7X=0
+9 FOR
SET LA7X=$ORDER(^LAB(60,LA760,3,LA7X))
if 'LA7X
QUIT
Begin DoDot:2
+10 ; file #62 pointer (collection sample)
SET LA762=+$GET(^LAB(60,LA760,3,LA7X,0))
+11 IF LA762
DO FDA629(LA7SCFG,LA760,LA762,"")
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
+14 ;
FDA629(LA7SCFG,LA760,LA762,LA76205) ; Add entry to TEST/PROFILE multiple
+1 ; Call with LA7SCFG = file #62.9, shipping configuration ien
+2 ; LA760 = file #60, lab test ien
+3 ; LA762 = file #62, collection sample ien
+4 ; LA76205 = file #62.05 , urgency ien
+5 NEW FDA,LA7DIE,LA7629
+6 SET LA7629(1)=LA7SCFG
+7 SET FDA(629,62.9001,"+2,"_+LA7SCFG_",",.01)=LA760
+8 IF LA76205
SET FDA(629,62.9001,"+2,"_+LA7SCFG_",",.04)=LA76205
+9 IF LA762
SET FDA(629,62.9001,"+2,"_+LA7SCFG_",",.09)=LA762
+10 if $X>(IOM-2)
WRITE !
WRITE "#"
+11 ; Add test to shipping configuration.
DO UPDATE^DIE("","FDA(629)","LA7629","LA7DIE(629)")
+12 QUIT
+13 ;
+14 ;
CLRSCT(LA7SCFG) ; Clear shipping configuration tests.
+1 ; Call with LA7SCFG = file #62.9, shipping configuration ien
+2 NEW DA,DIK,LA7X
+3 WRITE !!,"Clearing existing tests from configuration: ",$PIECE(LA7SCFG(0),"^"),!
+4 SET DA(1)=+LA7SCFG
SET DIK="^LAHM(62.9,"_DA(1)_",60,"
+5 SET LA7X=0
+6 FOR
SET LA7X=$ORDER(^LAHM(62.9,LA7SCFG,60,LA7X))
if 'LA7X
QUIT
Begin DoDot:1
+7 if $X>(IOM-2)
WRITE !
WRITE "*"
+8 SET DA=LA7X
DO ^DIK
End DoDot:1
+9 QUIT
