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

BLRAG09F.m

Go to the documentation of this file. 
  1. BLRAG09F ; IHS/MSC/SAT - SUPPORT FOR LABORATORY ACCESSION GUI RPCS ;
  1.  ;;5.2;IHS LABORATORY;**1031**;NOV 01, 1997;Build 185
  1.  ;print Shipping Manifest  LA7SMP
  1.  ;
  1. DEV(BLRDEV) ; Print Shipping Manifest
  1.  ; requires:
  1.  ;  LA7SCFG = Shipping Configuration pointer to file 62.9
  1.  ;  LA7SM   = Shipping Manifest pointer to file 62.8
  1.  ;
  1.  ; Determine if bar codes on manifest
  1.  S LA7SBC=$$GET1^DIQ(62.9,+LA7SCFG_",",.09,"I")
  1.  ; If not in shipping status then don't print, save paper
  1.  I $P($G(^LAHM(62.8,+LA7SM,0)),"^",3)<4 S LA7SBC=0
  1.  ;
  1.  S BLRDEV=$$DEV^BLRAG02(BLRDEV)
  1.  ;S %ZIS="MQ" D ^%ZIS
  1.  S:POP BLREF="-1^Print Error"
  1.  I POP S BLREF="-1^Print Error" Q
  1.  I BLRDEV=-1 S BLREF=-"1^Print Error" Q
  1.  Q:POP
  1. DQ ;
  1.  ;
  1.  U BLRDEV
  1.  ;
  1.  S LA7SM(0)=$G(^LAHM(62.8,+LA7SM,0))
  1.  S LA7SCFG=+$P(LA7SM(0),"^",2),LA7SCFG(0)=$G(^LAHM(62.9,LA7SCFG,0))
  1.  S (LA7DC,LA7EXIT,LA7END,LA7ITEM,LA7PAGE,LA7SMR,LA760,LA762801)=0
  1.  S (LA7FSITE,LA7TSITE)=""
  1.  ;
  1.  ; Get collecting site's names and station numbers
  1.  D GETSITE^LA7SMP($P(LA7SCFG(0),"^",2),$P(LA7SCFG(0),"^",3),.LA7FSITE,.LA7TSITE)
  1.  ;
  1.  ; Flag - skip if accession deleted
  1.  S LA7SKIP=0
  1.  ; Check manifest for missing info.
  1.  I $G(LA7CHK)="" S LA7CHK=1
  1.  ;
  1.  S LA7NOW=$$HTE^XLFDT($H,"1M")
  1.  ; Manifest status
  1.  S LA7SMST=$P(LA7SM(0),"^",3)
  1.  I LA7SMST=4 D
  1.  . ; Get shipping date
  1.  . S LA7SDT=$$SMED^LA7SMU(LA7SM,"SM05")
  1.  . ; Flag to print receipt.
  1.  . I IOST["P-" S LA7SMR=$P(LA7SCFG(0),"^",10)
  1.  ;
  1.  ; Set barcode flag to "off"
  1.  I LA7SBC,IOST'["P-" S LA7SBC=0
  1.  ;
  1.  S $P(LA7SMST,"^",2)=$$EXTERNAL^DILFD(62.8,.03,"",LA7SMST)
  1.  S LA7LINE="",$P(LA7LINE,"-",IOM)=""
  1.  S LA7SVIA=$S($P(LA7SM(0),"^",4):$$GET1^DIQ(62.92,$P(LA7SM(0),"^",4)_",",.01),1:"None Specified")
  1.  ;
  1.  F  S LA762801=$O(^LAHM(62.8,+LA7SM,10,LA762801)) Q:'LA762801  D
  1.  . F I=0,1,2 S LA762801(I)=$G(^LAHM(62.8,+LA7SM,10,LA762801,I))
  1.  . I $P(LA762801(0),"^",8)=0 Q  ; Test previously "removed".
  1.  . S LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
  1.  . I LA7SKIP,LA7SKIP<3 Q  ; Accession/test deleted
  1.  . I $G(LA7CHK) D CHKREQI^LA7SM2(+LA7SM,LA762801)
  1.  . ;S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^",9),$P(LA762801(0),"^",5),LA762801)=""  ;ihs/cmi/maw 8/4/2010 orig line
  1.  . S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^"),$P(LA762801(0),"^",5),LA762801)=""  ;ihs/cmi/maw 8/4/2010 changed sort to LRDFN from Packaging container
  1.  . ;S ^TMP("BLRSM",$J,+$P(LA762801(0),"^",7),+$P(LA762801(0),"^"),$$GETORDA^LA7VORM1($P(LA762801(0),"^",5)),LA762801)=""  ;ihs/cmi/maw 8/4/2010 changed sort to LRDFN from Packaging container
  1.  . D BUILDRI^LA7SM2
  1.  ;
  1.  S (LA7SCOND,LA7SCONT,LA7UID)=""
  1.  ;
  1.  I '$D(^TMP("BLRSM",$J)) D
  1.  . D HED^LA7SMP0
  1.  . W !!,$$CJ^XLFSTR("No entries to print",IOM)
  1.  ;
  1.  S BLRS3="" F  S BLRS3=$O(^TMP("BLRSM",$J,BLRS3)) Q:BLRS3=""  D  Q:LA7EXIT
  1.  .S BLRS4="" F  S BLRS4=$O(^TMP("BLRSM",$J,BLRS3,BLRS4)) Q:BLRS4=""  D  Q:LA7EXIT
  1.  ..S BLRS5="" F  S BLRS5=$O(^TMP("BLRSM",$J,BLRS3,BLRS4,BLRS5)) Q:BLRS5=""  D  Q:LA7EXIT
  1.  ...S BLRS6="" F  S BLRS6=$O(^TMP("BLRSM",$J,BLRS3,BLRS4,BLRS5,BLRS6)) Q:BLRS6=""  D  Q:LA7EXIT
  1.  ....I LA7EXIT Q
  1.  ....I $L(LA7UID),LA7UID'=BLRS5 W !,LA7LINE
  1.  ....I LA7SCOND'=BLRS3!(LA7SCONT'=BLRS4) D  Q:LA7EXIT
  1.  .....I $L(LA7UID),LA7UID=BLRS5 W !,LA7LINE
  1.  .....I LA7PAGE,+LA7SMST'=4 W ! D WARN^LA7SMP0
  1.  .....S LA7SCOND=BLRS3,LA7SCONT=BLRS4
  1.  .....D HED^LA7SMP0 S LA7UID=""
  1.  ....S LA762801=BLRS6
  1.  ....F I=0,.1,2,5 S LA762801(I)=$G(^LAHM(62.8,+LA7SM,10,LA762801,I))
  1.  ....S LA760=+$P(LA762801(0),"^",2) ; File #60 test ien
  1.  ....I LA7UID'=BLRS5 D  Q:LA7EXIT
  1.  .....S LA7UID=BLRS5
  1.  .....S LRDFN=+LA762801(0) D PTID^LA7SMP0
  1.  .....S BLRC3=LA7UID
  1.  .....S BLRC4="" F  S BLRC4=$O(^LRO(68,"C",BLRC3,BLRC4)) Q:BLRC4=""  D
  1.  ......S BLRC5="" F  S BLRC5=$O(^LRO(68,"C",BLRC3,BLRC4,BLRC5)) Q:BLRC5=""  D
  1.  .......S BLRC6="" F  S BLRC6=$O(^LRO(68,"C",BLRC3,BLRC4,BLRC5,BLRC6)) Q:BLRC6=""  D
  1.  ........I LA7UID'=BLRC3 S LA7SKIP=1 ; Skip - UID missing.
  1.  ........S LA7AA=+BLRC4,LA7AD=+BLRC5,LA7AN=+BLRC6
  1.  ........S LA7SKIP=$$CHKTST^LA7SMU(+LA7SM,LA762801)
  1.  ........I LA7SKIP,LA7SKIP<3 Q  ; Skip - accession/test deleted.
  1.  ........S LA7ACC=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,.2),"Accession not available"),"^")
  1.  ........S X=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,0),"Not available"),U,8)
  1.  ........S LA7PROV=$S(X>0:X,1:"")_"^"_$S(X>0:$$PRAC^LRX(X),1:X)
  1.  ........S LA7CDT=$P($G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,3),"Not available"),U,1)
  1.  ........S LA7SPEC=$G(^LRO(68,LA7AA,1,LA7AD,1,LA7AN,5,1,0),"Not available")
  1.  ........I LA7SPEC S LA7SPEC(0)=$G(^LAB(61,+LA7SPEC,0))
  1.  ........E  S LA7SPEC(0)="Specimen info not assigned"
  1.  ........S LA762=$P(LA7SPEC,"^",2)
  1.  ........I LA762 S LA762(0)=$G(^LAB(62,LA762,0))
  1.  ........E  S LA762(0)="Collection info not assigned"
  1.  ........S LA7ITEM=LA7ITEM+1
  1.  ........I ($Y+12)>IOSL D  Q:LA7EXIT
  1.  .........W !
  1.  .........I +LA7SMST'=4 D WARN^LA7SMP0
  1.  .........D HED^LA7SMP0
  1.  ........D SH^LA7SMP0
  1.  ....I LA7SKIP,LA7SKIP<3 Q  ; Skip - accession/test deleted.
  1.  ....I ($Y+6)>IOSL D  Q:LA7EXIT
  1.  .....W !,LA7LINE
  1.  .....I +LA7SMST'=4 W ! D WARN^LA7SMP0
  1.  .....D HED^LA7SMP0 Q:LA7EXIT
  1.  .....S LA7DC=1 D SH^LA7SMP0
  1.  ....;cmi/maw 7/6/2010 add insurance information here
  1.  ....D PRT^LA7VQINS(LA7UID)
  1.  ....W !,?11,$E(LA7LINE,1,41)
  1.  ....W !,?11,$P(^LAB(60,LA760,0),"^",1),?43,$P(LA7SPEC(0),"^")
  1.  ....I +LA7SMST'=4 D
  1.  .....N LA7TCOST
  1.  .....S LA7TCOST=$$GET1^DIQ(60,LA760_",",1,"E") Q:'$L(LA7TCOST)
  1.  .....W:$X>(IOM-15) ! W ?(IOM-15)," Cost: $",$FN(LA7TCOST,",",2)
  1.  ....I LA762801(.1)'="" D
  1.  .....K ^UTILITY($J),LA7CMT
  1.  .....S DIWL=1,DIWR=IOM-13,DIWF=""
  1.  .....S X="Relevant clinical information: "_LA762801(.1) D ^DIWP
  1.  .....M LA7CMT=^UTILITY($J,"W",DIWL)
  1.  .....W ! D CMT^LA7SMP0 W !
  1.  ....W ! D OCMT^LA7SMP0(LA7UID) W !  ;ihs/cmi/maw 07/26/2011 for ref lab
  1.  ....;W !,?13,"VA NLT Code [Name]: "  ;ihs/cmi/maw 8/4/2010 not wanted
  1.  ....;S LA7NLT=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",1) ; NLT code.  ;ihs/cmi/maw 8/4/2010 not wanted
  1.  ....;W $S($L(LA7NLT):LA7NLT,1:"*** None specified ***")  ;ihs/cmi/maw 8/4/2010 not wanted
  1.  ....;S LA7NLTN=""  ;ihs/cmi/maw 8/4/2010 not wanted
  1.  ....;I $L(LA7NLT) S LA7NLTN=$$GET1^DIQ(64,+$$GET1^DIQ(60,LA760_",",64,"I")_",",.01) ; NLT code test name.  ;ihs/cmi/maw 8/4/2010 not wanted
  1.  ....;I $L(LA7NLTN) W:($X+$L(LA7NLTN)+3)>IOM !,?32 W " [",LA7NLTN,"]"  ;ihs/cmi/maw 8/4/2010 not wanted
  1.  ....I $P(LA7SM(0),"^",5) D  ; Print non-VA test code info
  1.  .....N LA7X,LA7Y,LA7Z
  1.  .....S LA7X=$P($G(^DIC(4,+$P(LA7SCFG(0),"^",3),0),"UNKNOWN"),"^",1)_" Order Code [Name]: "
  1.  .....W !,?11,LA7X,$S($L($P(LA762801(5),"^")):$P(LA762801(5),"^"),1:"*** None specified ***")," "
  1.  .....S LA7Y="["_$S($L($P(LA762801(5),"^",2)):$P(LA762801(5),"^",2),1:"*** None specified ***")_"]"
  1.  .....I $L(LA7Y)<(IOM-$X) D  Q
  1.  ......W LA7Y
  1.  ......D AO^LA7VQINS(LA7UID)
  1.  .....S LA7X=IOM-$X W $E(LA7Y,1,LA7X)
  1.  .....;lets try adding ask at order questions here
  1.  .....D AO^LA7VQINS(LA7UID)
  1.  .....S LA7Y=$E(LA7Y,LA7X+1,$L(LA7Y)),LA7Z=IOM-11
  1.  .....F  S LA7X=$E(LA7Y,1,LA7Z) Q:LA7X=""  W !,?11,LA7X S LA7Y=$E(LA7Y,LA7Z+1,$L(LA7Y))
  1.  ;
  1.  I LA7EXIT Q
  1.  ;
  1.  W !,LA7LINE,!!,"End of Shipping Manifest"
  1.  ;
  1.  I +LA7SMST'=4 D
  1.  . I IOM<131 W !
  1.  . D WARN^LA7SMP0
  1.  ;
  1.  ; Print shipping manifest receipt.
  1.  I LA7SMR D
  1.  . ; Flag that we're now printing receipt
  1.  . S $P(LA7SMR,"^",2)=1
  1.  . D HED^LA7SMP0
  1.  . W !!,"Number of specimens: ",LA7ITEM
  1.  . W !!,"Receipted by: ",$$REPEAT^XLFSTR("_",40)
  1.  . W !!,"   Date/time: ",$$REPEAT^XLFSTR("_",20)
  1.  ;
  1.  ; Print error listing if any.
  1.  I $O(LA7ERR(""))'="" D
  1.  .S $P(LA7SMR,"^",2)=2 ; Flag printing of error listing
  1.  .D HED^LA7SMP0
  1.  .S LA7I=0
  1.  .F  S LA7I=$O(LA7ERR(LA7I)) Q:LA7I=""  D  Q:LA7EXIT
  1.  ..I ($Y+6)>IOSL D HED^LA7SMP0 Q:LA7EXIT
  1.  ..W LA7ERR(LA7I)
  1.  ..S BLRS3=LA7I
  1.  ..S BLRS4=$P(LA7SM,"^",1)
  1.  ..S BLRS5="" F  S BLRS5=$O(^TMP("LA7ERR",$J,BLRS3,BLRS4,BLRS5)) Q:BLRS5=""  D  Q:LA7EXIT
  1.  ...S BLRS6="" F  S BLRS5=$O(^TMP("LA7ERR",$J,BLRS3,BLRS4,BLRS5,BLRS6)) Q:BLRS6=""  D  Q:LA7EXIT
  1.  ....I ($Y+6)>IOSL D HED^LA7SMP0 Q:LA7EXIT  W LA7ERR(LA7I)," (Cont'd)"
  1.  ....;W !,?10,"UID: ",BLRS5,"  Test: ",$$GET1^DIQ(60,BLRS6_",",.01)
  1.  ....W !,?10,"UID: ",BLRS5,"  Test: ",$$TESTNAME^BLRAGUT(+BLRS6)
  1.  ...W !!
  1.  ;
  1.  I $D(ZTQUEUED) D END^LA7SMP0
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. GETSITE(LA7X,LA7Y,LA7FS,LA7TS) ; Setup variables for ordering and host sites
  1.  ;
  1.  ; Call with  LA7X = File #4 ordering site ien
  1.  ;            LA7Y = File #4 host site ien
  1.  ;            LA7FS = array to return collecting site info
  1.  ;            LA7TS = array to return host site info
  1.  ;
  1.  ; Get ordering site's names and station numbers
  1.  S LA7FS=$$GET1^DIQ(4,LA7X_",",.01)
  1.  I LA7FS="" S LA7FS="UNKNOWN:Entry #"_+LA7X
  1.  S LA7FS(99)=$$RETFACID^LA7VHLU2(LA7X,2,1)
  1.  I LA7FS(99)="" S LA7FS(99)="UNK: #"_+LA7X
  1.  ;
  1.  ; Get host site's names and station numbers
  1.  S LA7TS=$$GET1^DIQ(4,LA7Y_",",.01)
  1.  I LA7TS="" S LA7TS="UNKNOWN:Entry #"_+LA7Y
  1.  S LA7TS(99)=$$RETFACID^LA7VHLU2(LA7X,1,1)
  1.  I LA7TS(99)="" S LA7TS(99)="UNK: #"_+LA7Y
  1.  Q
  1.  ;
  1.  ;
  1. ASK(LA7SM) ; Ask it user wants to print manifest.
  1.  ;  Call with array LA7SM = ien of 62.8^.01 field of #62.8
  1.  ;
  1.  N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1.  ;
  1.  S DIR(0)="YO",DIR("A")="Print Shipping Manifest",DIR("B")="NO"
  1.  D ^DIR Q:$D(DIRUT)
  1.  I Y=1 D DEV,END^LA7SMP0
  1.  ;
  1.  Q