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

LA7SCE.m

Go to the documentation of this file. 
  1. LA7SCE ;VA/DALOI/JMC - Shipping Configuration Utility ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;AUTOMATED LAB INSTRUMENTS;**27,46,61,64,1027**;NOV 01, 1997
  1.  Q
  1.  ;
  1. SCFE ; Edit file #62.9, Shipping Configuration.
  1.  ;
  1.  N DA,DIE,DIC,DIR,DLAYGO,DIRUT,DR,DTOUT,DIROUT,X,Y
  1.  N LA7CHECK,LA7COPY,LA7NVAF,LA7SCFG,LA7SCFR,LA7TYPE,LA7VAF,LA7X,LR62,LRSS
  1.  ;
  1.  S DIC="^LAHM(62.9,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING CONFIGURATION: "
  1.  S DIC("DR")=".02;.03",DLAYGO=62.9
  1.  D ^DIC
  1.  K DA,DIC,DIE,DR
  1.  I Y<1 Q
  1.  ;
  1.  S LA7SCFG=+Y,LA7SCFG(0)=Y(0)
  1.  ;
  1.  L +^LAHM(62.9,LA7SCFG):5
  1.  I '$T D  Q
  1.  . D EN^DDIOL("Unable to obtain lock on entry "_$P(LA7SCFG(0),"^"),"","!?3")
  1.  ;
  1.  S DIR(0)="SO^1:Collecting facility;2:Host facility",DIR("A")="Are you editing this entry as the"
  1.  S DIR("?",1)="Is this entry used by the Collecting facility to ship specimens,"
  1.  S DIR("?",2)="or by the Host facility to accept a shipment."
  1.  S DIR("?")="This determines which fields are edited in the file."
  1.  D ^DIR
  1.  I $D(DIRUT) D UNL629 Q
  1.  S LA7TYPE=+Y
  1.  ;
  1.  ; Determine if other facility is non-VA.
  1.  ; When acting as collecting facility is host non-VA
  1.  ; When acting as host is collecting facility non-VA
  1.  S LA7VAF="",LA7NVAF=0
  1.  I $P(LA7SCFG(0),"^",2),$P(LA7SCFG(0),"^",3) D
  1.  . S LA7X=$S(LA7TYPE=1:$P(LA7SCFG(0),"^",3),1:$P(LA7SCFG(0),"^",2))
  1.  . S LA7VAF=$$GET1^DIQ(4,LA7X_",","AGENCY CODE","I")
  1.  . S LA7NVAF=$$NVAF^LA7VHLU2(LA7X)
  1.  I LA7VAF="" D  Q
  1.  . N LA7MSG
  1.  . S LA7MSG="Unable to proceed - institution "
  1.  . S LA7MSG=LA7MSG_$$GET1^DIQ(4,$S(LA7TYPE=1:$P(LA7SCFG(0),"^",3),1:$P(LA7SCFG(0),"^",2))_",",.01)
  1.  . S LA7MSG=LA7MSG_" missing AGENCY CODE field in INSITUTION file (#4)"
  1.  . D EN^DDIOL(LA7MSG,"","!!?3")
  1.  . D UNL629
  1.  ;
  1.  ; If acting as host ask if user wants to copy test config from another entry.
  1.  I LA7TYPE=2 D
  1.  . N DIC,Y
  1.  . S LA7COPY=$$ASKCOPY
  1.  . I LA7COPY<1 Q
  1.  . S LA7CHECK=$$CHECK(LA7SCFG)
  1.  . I LA7CHECK<1 S LA7COPY=LA7CHECK Q
  1.  . I LA7COPY<1 Q
  1.  . I LA7COPY=1 D  Q
  1.  . . S DIC="^LAHM(62.9,",DIC(0)="AEMQZ",DIC("A")="Select SHIPPING CONFIGURATION to COPY FROM: ",DIC("S")="I Y'=LA7SCFG"
  1.  . . D ^DIC K DIC("S")
  1.  . . I Y<1 Q
  1.  . . S LA7SCFR=+Y,LA7SCFR(0)=Y(0)
  1.  . . D CLRSCT(.LA7SCFG)
  1.  . . D COPYSC(.LA7SCFR,.LA7SCFG)
  1.  . I LA7COPY=2 D  Q
  1.  . . D CLRSCT(.LA7SCFG)
  1.  . . D COPY60(.LA7SCFG)
  1.  I LA7TYPE=2,LA7COPY<0 D UNL629 Q
  1.  K DA,DIE,DIC,DIR,DLAYGO,DIRUT,DR,DTOUT,DIROUT,X,Y
  1.  ;
  1.  ; Set up DR string when acting as collecting facility
  1.  I LA7TYPE=1 D
  1.  . S DR=".01;.02;.06;.03;.031;"
  1.  . I LA7NVAF>1 S DR=DR_".11;.12;.14;.15;"
  1.  . I LA7NVAF=1 S DR=DR_".14////1;.15////1;"
  1.  . S DR=DR_".04;.07;.08;.09;.1;.13;60"
  1.  . S DR(2,62.9001)=".01;.02;.025;.03;.04;.05;.06;.07"
  1.  ;
  1.  ; Set up DR string when acting as host facility
  1.  I LA7TYPE=2 D
  1.  . S DR=".01;.02;.06;.03;.031;"
  1.  . I LA7NVAF>1 S DR=DR_".11;.14;.15;"
  1.  . I LA7NVAF=1 S DR=DR_".14////0;.15////1;"
  1.  . S DR=DR_".04;.05;60"
  1.  . S DR(2,62.9001)=".01;S LRSS=$P(^LAB(60,X,0),U,4);.04;.09;S LR62=X I LRSS'=""MI"" S Y=""@2"";I LR62,$P(^LAB(62,LR62,0),U,2)'="""" S Y=""@2"";.03;5.7;@2"
  1.  ;
  1.  ; Determine if non-VA test codes/specimen fields should be asked
  1.  I LA7VAF'="V" D
  1.  . 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"
  1.  . I LA7TYPE=1,LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99LST"
  1.  . S DR(2,62.9001)=DR(2,62.9001)_";@9"
  1.  . I LA7TYPE=1 D
  1.  . . 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"
  1.  . . I LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99LRP;5.7;5.8;5.9////99LRS"
  1.  . . S DR(2,62.9001)=DR(2,62.9001)_";@10"
  1.  . I LA7TYPE=2 D
  1.  . . 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"
  1.  . . I LA7NVAF=1 S DR(2,62.9001)=DR(2,62.9001)_"////99LRP"
  1.  . . S DR(2,62.9001)=DR(2,62.9001)_";@10"
  1.  ;
  1.  I LA7TYPE=1 D
  1.  . N J,K
  1.  . S DR(2,62.9001)=DR(2,62.9001)_";"
  1.  . 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"
  1.  . I ($L(DR(2,62.9001))+$L(X))<246 S DR(2,62.9001)=DR(2,62.9001)_X Q
  1.  . S K=$L(X,";")
  1.  . F J=1:1:K D
  1.  . . I ($L(DR(2,62.9001))+$L($P(X,";")))>244 S J=K Q
  1.  . . S DR(2,62.9001)=DR(2,62.9001)_$P(X,";")_";",X=$P(X,";",2,K)
  1.  . I X'="" S DR(2,62.9001,1)=X
  1.  ;
  1.  S DA=LA7SCFG,DIE="^LAHM(62.9,"
  1.  D ^DIE,UNL629
  1.  Q
  1.  ;
  1.  ;
  1.  ; Unlock entry in 62.9
  1. UNL629 L -^LAHM(62.9,LA7SCFG)
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. SCTE ; Edit file #62.91, Shipping Container.
  1.  N DA,DIE,DIC,DLAYGO,DR,X,Y
  1.  S DIC="^LAHM(62.91,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING CONTAINER: ",DLAYGO=62.91
  1.  D ^DIC
  1.  I Y<1 Q
  1.  S DA=+Y,DIE=DIC,DR=".01;.02"
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. SCME ; Edit file #62.92, Shipping Method.
  1.  N DA,DIE,DIC,DLAYGO,DR,X,Y
  1.  S DIC="^LAHM(62.92,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING METHOD: ",DLAYGO=62.92
  1.  D ^DIC
  1.  I Y<1 Q
  1.  S DA=+Y,DIE=DIC,DR=".01;.02"
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. SCDE ; Edit file #62.93, Shipping Condition.
  1.  N DA,DIE,DIC,DLAYGO,DR,X,Y
  1.  S DIC="^LAHM(62.93,",DIC(0)="AELMQZ",DIC("A")="Select SHIPPING CONDITION: ",DLAYGO=62.93
  1.  D ^DIC
  1.  I Y<1 Q
  1.  S DA=+Y,DIE=DIC,DR=".01;.02"
  1.  D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. 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
  1.  ;                  = 0 do not copy
  1.  ;                  = 1 use file #60
  1.  ;                  = 2 use another entry in #62.49
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="SMO^0:Do NOT copy;1:Another Shipping Configuration;2:Test Catalog - LABORATORY TEST File #60"
  1.  S DIR("A")="Copy a test profile from",DIR("B")="Do NOT copy"
  1.  S DIR("?",1)="If you want to duplicate a shipping configuration using another configuration"
  1.  S DIR("?",2)="or build from the tests marked as catalog tests in the LABORATORY TEST file."
  1.  S DIR("?")="Select the appropiate option."
  1.  D ^DIR
  1.  I $D(DIRUT) S Y=-1
  1.  Q Y
  1.  ;
  1.  ;
  1. CHECK(LA7SCFG) ; Check if test exists for configuration and warn if overwriting
  1.  ; Call with LA7SCFG = shiping configuration ien
  1.  ;   Returns  -1 = user aborted/timeout
  1.  ;             0 = no - don't overwrite
  1.  ;             1 = yes - overwrite
  1.  I '$O(^LAHM(62.9,LA7SCFG,60,0)) Q 1
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  S DIR(0)="SBO^0:NO;1:YES"
  1.  S DIR("A",1)="Tests already exist for this configuration!",DIR("A")="Are you sure",DIR("B")="NO"
  1.  D ^DIR
  1.  I $D(DIRUT) S Y=-1
  1.  Q Y
  1.  ;
  1.  ;
  1. COPYSC(LA7FR,LA7TO) ; Copy one shipping configuration to another
  1.  ; Call with LA7FR = shipping configuration to copy FROM.
  1.  ;           LA7TO = shipping configuration ien to copy TO.
  1.  N LA760,LA762,LA6205,LA7X
  1.  W !!,"Copying tests from configuration: ",$P(LA7FR(0),"^")," to ",$P(LA7TO(0),"^"),!
  1.  S LA7X=0
  1.  F  S LA7X=$O(^LAHM(62.9,LA7FR,60,LA7X)) Q:'LA7X  D
  1.  . S LA760=$P($G(^LAHM(62.9,LA7FR,60,LA7X,0)),"^") ; file #60 laboratory test ien.
  1.  . S LA76205=$P($G(^LAHM(62.9,LA7FR,60,LA7X,0)),"^",4) ; file #62.05, urgency ien.
  1.  . S LA762=$P($G(^LAHM(62.9,LA7FR,60,LA7X,0)),"^",9) ; file #62, collection sample ien.
  1.  . I LA760 D FDA629(LA7TO,LA760,LA762,LA76205)
  1.  Q
  1.  ;
  1.  ;
  1. 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
  1.  N LA760,LA762,LA7X
  1.  W !!,"Copying tests from file #60 LABORATORY TEST to ",$P(LA7SCFG(0),"^"),!
  1.  S LA760=0 ; file #60 pointer
  1.  I '$D(^LAHM(62.9,LA7SCFG,60,0)) S ^LAHM(62.9,LA7SCFG,60,0)="^62.9001P^0^0" ; set subfile zeroth node
  1.  F  S LA760=$O(^LAB(60,LA760)) Q:'LA760  D
  1.  . I '$P($G(^LAB(60,LA760,64)),"^",3) Q  ; Not a catalog item
  1.  . S LA7X=0
  1.  . F  S LA7X=$O(^LAB(60,LA760,3,LA7X)) Q:'LA7X  D
  1.  . . S LA762=+$G(^LAB(60,LA760,3,LA7X,0)) ; file #62 pointer (collection sample)
  1.  . . I LA762 D FDA629(LA7SCFG,LA760,LA762,"")
  1.  Q
  1.  ;
  1.  ;
  1. FDA629(LA7SCFG,LA760,LA762,LA76205) ; Add entry to TEST/PROFILE multiple
  1.  ; Call with  LA7SCFG = file #62.9, shipping configuration ien
  1.  ;              LA760 = file #60, lab test ien
  1.  ;              LA762 = file #62, collection sample ien
  1.  ;            LA76205 = file #62.05 , urgency ien
  1.  N FDA,LA7DIE,LA7629
  1.  S LA7629(1)=LA7SCFG
  1.  S FDA(629,62.9001,"+2,"_+LA7SCFG_",",.01)=LA760
  1.  I LA76205 S FDA(629,62.9001,"+2,"_+LA7SCFG_",",.04)=LA76205
  1.  I LA762 S FDA(629,62.9001,"+2,"_+LA7SCFG_",",.09)=LA762
  1.  W:$X>(IOM-2) ! W "#"
  1.  D UPDATE^DIE("","FDA(629)","LA7629","LA7DIE(629)") ; Add test to shipping configuration.
  1.  Q
  1.  ;
  1.  ;
  1. CLRSCT(LA7SCFG) ; Clear shipping configuration tests.
  1.  ; Call with LA7SCFG = file #62.9, shipping configuration ien
  1.  N DA,DIK,LA7X
  1.  W !!,"Clearing existing tests from configuration: ",$P(LA7SCFG(0),"^"),!
  1.  S DA(1)=+LA7SCFG,DIK="^LAHM(62.9,"_DA(1)_",60,"
  1.  S LA7X=0
  1.  F  S LA7X=$O(^LAHM(62.9,LA7SCFG,60,LA7X)) Q:'LA7X  D
  1.  . W:$X>(IOM-2) ! W "*"
  1.  . S DA=LA7X D ^DIK
  1.  Q