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

LRHYAFT.m

Go to the documentation of this file. 
  1. LRHYAFT ;VA/DALOI/HOAK - HOWDY MAIN DRIVER WITH PPOC ADDON ;08/28/2005  ;12/13/10 11:19am
  1.  ;;5.2;LAB SERVICE;**405,417,435**;NOV 01, 1997;Build 31
  1.  ;
  1.  ; TAKEN FROM LRHY0
  1. PICK ;
  1.  ;  pick the site from Howdy Site
  1.  S LREND=0
  1.  S DIC(0)="AEMQZ"
  1.  S DIC=69.86
  1.  D ^DIC
  1.  I Y=-1 S LREND=1 QUIT
  1.  S LRHYSITE=+Y
  1.  K DIC
  1.  ;
  1.  ;
  1.  ; Pick a printer
  1.  I LRHYSITE=$O(^LRHY(69.86,"B","ALTERNATIVE",0)) ;QUIT
  1.  S LRDEV=0
  1.  K DIC
  1.  S DIC(0)="EMQZ" K Y S LRHYCT2=1
  1.  F  S LRDEV=$O(^LRHY(69.86,LRHYSITE,10,"B",LRDEV)) Q:+LRDEV'>0  D
  1.  .  W !,LRHYCT2,". ",$P(^%ZIS(1,LRDEV,0),U)
  1.  .  S LRX(LRHYCT2)=LRDEV S LRHYCT2=LRHYCT2+1
  1. CHOOO W !,"Choose a label printer: " R X:DTIME W !
  1.  I U[X S LREND=1 QUIT
  1.  I 'X I $G(X)'="" W !,"enter the number please" G CHOOO
  1.  S LRDEV=LRX(X)
  1.  W ?11,$P(^%ZIS(1,LRDEV,0),U) H 2
  1.  K DIC
  1.  K LRHYCT2
  1.  ;
  1.  QUIT
  1.  ;
  1. VET ; Primary API for Howdy!  Called by [LRHY PATIENT CARD SCAN (PPOC)] option.
  1.  K XX,LRAAX5,LRADX6,LRAN6,LRINFW,LRPREF,LRTOP,LR3UIDM,LRXL,ZTSAVE,ZTIO,ZTDTH,ZTDESC,ZTRTN
  1.  K LR3CNT S LR3CNT=0
  1.  S LR3CNT=1
  1.  N LRDFN,PNM,LRSN,SSN,LRIDT,LRAA,LRAN,LRAD
  1.  D KILL^%ZISS
  1.  K LRSCAN
  1.  K LRNOW,LRXCNT
  1.  N LRNPZZX,LRNODUP,LRLLOC,LRTSTZ99,LRACC,LRCDT,LRDPF,LRI
  1.  N LRORD3,LRHYFIX,LRPLICK,LRPR,LRPRAC,LRQUIET,LRRB,LRSAMP,LRSND
  1.  N LRSS,LRST,LRSTATUS,LRSUB1,LRTIC,LRTIM,LRTN,LRTREA,LRTS,LRTSORU
  1.  N LRTST6,LRTT,LRUN,LRWLO,LRWLC,LRWRD,LRXYZ,LR3DTIME,LR3DTN
  1.  N LR3SN,LRDT0,LREAL,LRFUTURE,LRGOTIT,LRHOWDY,LRHYHOK,LRIENZZ
  1.  N LRNOTST,LRLBLBP,LRLLOC66,LRMAX2,LRNLT,LRNODUP,LRNONE,LRNPZZX,LRODT
  1.  N LRODT0,LRHYOK,LRORD24,LRORU3,LRPAST,LRPIX,LRAHEAD,LRCHK,LRHYCT,LRCOL99
  1.  N LRDT0,LRDUPT,LRHT1,LRIX,LROLLOC,LRX,LR3X
  1.  ;
  1. VET1 ; Code below executes to handle Patient episode.
  1.  K DIC
  1.  I $G(LRHYSITE)="" S DIC=69.86,DIC(0)="AEMQZ" D ^DIC Q:'Y  S LRHYSITE=+Y
  1.  I LRHYSITE=-1 W !,"No Howdy site selected. Goodbye. " K LRHYSITE,LRDEV,LRLABLIO QUIT
  1.  ; Then, Howdy waits here for next Patient
  1.  I $G(LRDEV)'="" G V2
  1.  S DIC("A")="WHICH LABEL PRINTER:"
  1.  S DIC="^%ZIS(2,"
  1.  S DIC(0)="AEMQZ"
  1.  S DIC=3.2
  1.  S DIC="^%ZIS(1,"
  1.  S DIC(0)="AEMQZN"
  1.  I '$G(LRDEV) D ^DIC Q:+Y=0  S LRDEV=+Y S LRLABLIO=LRDEV
  1.  I Y=-1 W !,"No device selected. Goodbye. " K LRLABLIO,LRDEV,LRHYSITE QUIT
  1.  D ^LRHYBL1
  1.  I $G(LRLABSTP)'="" S LRLABLIO=LRLABLIO_";"_LRLABSTP
  1.  I '$G(LRDEV) D PICK Q:LREND
  1. V2 ;
  1.  ;
  1.  K LRDFN,PNM,LRSN,SSN,LRIDT,LRAA,LRAN,LRAD
  1.  D ^LRPARAM ; Set Howdy up as Lab user
  1.  S LRHOWDY=1
  1.  S LRHYCT=$G(LRHYCT,0)
  1.  ;
  1.  S LRODT=DT
  1.  W @IOF
  1.  K X
  1.  ; 
  1.  W !!,"Please swipe PATIENT ID CARD or Type SSN: "
  1.  ; %ZOSF("EOFF") = U $I:NOECHO
  1.  ; %ZOSF("EON") = U $I:ECHO
  1.  R X:9999999 W !
  1.  I X=U D SCROLOFF^LRHYBC9 QUIT
  1.  ; Code is set to read all types of VIC card as of 9/05/2005
  1.  ;I $E(X,1,9)["-" D
  1.  ;.  S X=$P(X,"-")_$P(X,"-",2)_$P(X,"-",3)
  1.  ;I $E(X,1,1)'=0 I '$E(X,1,1) S X=$E(X,2,10)
  1.  ;I $L(X)>10 S X=$E(X,2,10)
  1.  ;I $L(X)'=9 S LR3CNT=LR3CNT+1
  1.  ;I $L(X)'=9 W !,"Didn't read that Partner. " W:LRHYCT'=2 "Try again." H 2 S LRHYCT=LRHYCT+1 G VET1
  1. NSCN ;
  1.  K DFN,LRDFN,LRDPA,LRDPF,PNM,LRHYCT
  1.  ; 
  1.  ;S DFN=$O(^DPT("SSN",X,0))
  1.  ;
  1.  ; NEW CODE FOR VHIC 4.0
  1.  D RPCVIC^DPTLK(.DFN,X)
  1.  I DFN<1 W !,"No record for this person." R X:15 G VET
  1.  S LRDFN=$G(^DPT(DFN,"LR"))
  1.  ;
  1.  I LRDFN D PT^LRX
  1.  I 'LRDFN W !,"No Lab Data Available... Please check with clerk at the Desk." H 5 D LOG K X G VET
  1.  K ^TMP("LRHYDY",$J,"LRHYDY",$J,LRDFN)
  1.  ;
  1.  ; this call checks order against the 69.86
  1.  W !,"I'M DOING THE BEST I CAN"
  1.  ; HERE IS WHERE WE PRINT LABELS ACCESSIONED EARLIER 2/25/2009 DRH
  1. PX ;
  1.  N LRX,LRY
  1.  I 'LRDFN S LRDFN=^DPT(DFN,"LR")
  1.  W @IOF
  1.  W !,PNM,?40,SSN,"   ",$$Y2K^LRX(DOB)
  1.  S LRADD=$G(^DPT(DFN,.11))
  1.  I LRADD'="" W !,$P(LRADD,U),?35," ",$P(LRADD,U,4)," ",$P(^DIC(5,$P(LRADD,U,5),0),U)
  1.  S LRPHONE=$P($G(^DPT(DFN,.121)),U,10) I $G(LRPHONE) W " Ph#:",$G(LRPHONE)
  1.  H 3
  1.  S DIR("B")="NO",DIR(0)="Y",DIR("A")="PT CONFIRMATION PROMPT. Is this the correct Patient?"
  1.  D ^DIR
  1.  I Y[U D SCROLOFF^LRHYBC9 W @IOF QUIT
  1.  I $G(Y(0))'="YES" W !!,"PT CONFIRMATION FAILED..." H 3 QUIT
  1.  S LR3UID=""
  1.  W @IOF
  1.  D ENS^%ZISS
  1.  W *27,*91,*109 W *27,*91,45,*109
  1.  W IODHLT," ",PNM
  1.  W !
  1.  W IODHLB," ",PNM
  1.  W !
  1.  W !
  1.  W IODHLT," ",SSN
  1.  W !
  1.  W IODHLB," ",SSN
  1.  W *27,"[",40,";",37,"m",!
  1.  W !
  1.  W ! D LRGLIN^LRX W !
  1.  S LRX=0
  1.  S CNT=0
  1.  K LRLABTIM S LRLABTIM=$O(^XTMP("LRHY LABELS",LRDFN,DT))
  1.  I $G(LRLABTIM)="" W !,"NOTHING TO PRINT ON ",PNM H 2 QUIT
  1.  D LRBOX^LRHYLRX(60,6,5,15," ")
  1.  F  S LR3UID=$O(^XTMP("LRHY LABELS",LRDFN,LRLABTIM,LR3UID)) Q:LR3UID=""  D
  1.  .  I $L(LR3UID)<10 W !,"UID < 10 CHRS. ACCESSION MANUALLY" H 2 QUIT
  1.  .  K LRLABNO S LRLABNOD=$G(^XTMP("LRHY LABELS",LRDFN,LRLABTIM,LR3UID))
  1.  .  S LRY=0
  1.  .  S LRX=$O(^LRO(68,"C",LR3UID,0))
  1.  .  I '$G(LRX) D MICRO
  1.  .  Q:'$G(LRX)
  1.  .  S LRY1=$O(^LRO(68,"C",LR3UID,LRX,0))
  1.  .  S LRY=$O(^LRO(68,"C",LR3UID,LRX,LRY1,LRY))
  1.  .  D
  1.  ..  S LRLBL(LRX,LRY)=LRLABNOD
  1.  ..  S CNT=CNT+1 S LABCNT(CNT)=LRLBL(LRX,LRY)
  1.  ..  S LRXCNT(CNT)=LRX_U_LRY
  1.  ..  S X=62,Y=5
  1.  ..  S LRAD=$G(LRY1)
  1.  ..  W !,CNT,") ",$P(LRLBL(LRX,LRY),U,6)
  1.  ..  I '$G(LRAD) S LRAD=DT
  1.  ..  W ?21,$P(^LAB(62,$P(^LRO(68,LRX,1,LRAD,1,LRY,5,1,0),U,2),0),U,3)
  1.  S LRX=0
  1.  S LRX=0
  1.  S DY=5
  1.  S DY=6
  1.  F  S LRX=$O(LRLBL(LRX)) Q:+LRX'>0  S DX=62,LRC=$O(LRLBL(LRX,0)),LRAD=$P(LRLBL(LRX,LRC),U,2),DY=DY+1 X IOXY K LR3UID S LR3UID=$G(^LRO(68,LRX,1,LRAD,1,LRC,.3)) W LR3UID
  1.  ;
  1.  W !!
  1.  W !! H 4
  1.  D ENS^%ZISS S IOTM=16,IOBM=23
  1.  ;
  1.  W @IOSTBM
  1.  W !!
  1.  H 3
  1.  W !
  1.  S DX=0,DY=13 X IOXY
  1.  S DX=0,DY=17 X IOXY
  1.  W !!," Proceed with COLLECTION:" W *7
  1.  W !!
  1.  W !,"Select specimen(s) you actually collected to print corresponding labels:"
  1. SL ;
  1.  R LRS:DTIME W ! I LRS["-" G QQQ
  1. QQQ ;
  1.  F I=1:1:10 Q:+$P(LRS,",",I)'>0  S LRS3333=+$P(LRS,",",I) I '$D(LABCNT(LRS3333)) W !,"OUT OF RANGE" H 3 G PX
  1.  K LRLBL
  1.  I LRS["?" W !,"You may enter 1 OR 2 OR 1,2,3,etc NO DASHES(-) PLEASE " H 4 G PX
  1.  I LRS["," F LRXX=1:1:CNT S I=$P(LRS,",",LRXX) Q:+I'>0  S LRX=$P(LRXCNT(I),U),LRY=$P(LRXCNT(I),U,2) D
  1.  .  S LRAD=DT
  1.  .  I $P(^LRO(68,LRX,0),U,3)="Y" S LRAD=$E(DT,1,3)_"0000"
  1.  .  I $P(^LRO(68,LRX,0),U,3)="M" S LRAD=$E(DT,1,5)_"00"
  1.  .  W !,"Sending to print: ",$P($G(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U),"  ",$P(^LAB(62,$P(^LRO(68,LRX,1,LRAD,1,LRY,5,1,0),U,2),0),U,3)
  1.  .  S LRORD=$G(^LRO(68,LRX,1,LRAD,1,LRY,.1))
  1.  .  I $P($G(LRXCNT(I)),U,2)="" QUIT
  1.  .  S LRLBL(LRX,$P(LRXCNT(I),U,2))=LABCNT(I)_$G(LRORD)
  1.  .  S LR3UID=$P($G(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U)
  1.  .  D BCE^LRHYPH0
  1.  .  K ^XTMP("LRHY LABELS",LRDFN,LRLABTIM,LR3UID)
  1.  I LRS["-" W !,"DASHES ARE NOT PERMITTED. ENTER 1,2,3 ETC" H 1 G PX
  1.  I $G(LRXCNT(+LRS))="" W !,"OUT OF RANGE. TRY AGAIN" H 2 G PX
  1.  E  I $L(LRS)=1 I $G(LRXCNT(LRS))'="" S I=LRS Q:+I'>0  S LRX=$P(LRXCNT(I),U),LRY=$P(LRXCNT(I),U,2) D
  1.  .  S LRAD=DT
  1.  .  I $P(^LRO(68,LRX,0),U,3)="M" S LRAD=$E(DT,1,5)_"00"
  1.  .  I $P(^LRO(68,LRX,0),U,3)="Y" S LRAD=$E(DT,1,3)_"0000"
  1.  .  W !,"Sending to print: ",$P($G(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U),"  ",$P(^LAB(62,$P(^LRO(68,LRX,1,LRAD,1,LRY,5,1,0),U,2),0),U,3)
  1.  .  S LR3UID=$P($G(^LRO(68,LRX,1,LRAD,1,LRY,.3)),U)
  1.  .  S LRORD=$G(^LRO(68,LRX,1,LRAD,1,LRY,.1))
  1.  .  S LRLBL(LRX,$P(LRXCNT(LRS),U,2))=LABCNT(LRS)_$G(LRORD)
  1.  .  W !,"REMOVING ",LR3UID H 2
  1.  .  D BCE^LRHYPH0
  1.  .  S LRSCAN=$G(LRLABTIM)
  1.  .  K ^XTMP("LRHY LABELS",LRDFN,LRLABTIM,LR3UID)
  1.  H 4
  1.  I '$D(^XTMP("LRHY LABELS",LRDFN,LRLABTIM)) G VIE
  1.  K DIR
  1.  S DIR("A")="What shall we do with these?"
  1.  ;
  1.  S DIR(0)="S^1:Delete;C:Collect;"
  1.  S DIR("B")="Delete"
  1.  D ^DIR Q:X[U
  1.  I Y="C" G PX
  1.  I Y=1 D DEL7 W !,"Use Lab option > Accessioning Menu: Delete test from an accession [LRTSTOUT]" H 2
  1.  ;
  1. VIE ;
  1.  D CONTROL^LRHYBC1
  1.  H 3 W @IOF
  1.  D SCROLOFF^LRHYBC9
  1.  QUIT
  1. MICRO ;
  1.  S LRACNODE=^XTMP("LRHY LABELS",LRDFN,LRLABTIM,LR3UID)
  1.  S LRACCXX=$P(LRACNODE,U,6)
  1.  S LR68=$P(LRACCXX," ") S LRAA=$O(^LRO(68,"B",LR68,0))
  1.  S LRAN=$P(LRACCXX," ",3)
  1.  S LRAD=$P(LRACNODE,U,2)
  1.  S LR3UIDM=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.3))
  1.  S LRX=$O(^LRO(68,"C",LR3UID,0))
  1.  QUIT
  1.  ;
  1. PRT1 ;
  1.  ;
  1.  W @IOF
  1.  D SCRNON^LRHYUTL
  1.  K PNMALL S PNMALL="Howdy "_$P(PNM,",",2)_" "_$P(PNM,",")
  1.  W !
  1.  W IODHLT,"     ",PNMALL
  1.  W !
  1.  W IODHLB,"     ",PNMALL
  1.  W !
  1.  W !,$$CJ^XLFSTR($G(^LRHY(69.86,LRHYSITE,40)),IOM)
  1.  W !,$$CJ^XLFSTR($G(^LRHY(69.86,LRHYSITE,44)),IOM)
  1.  W !
  1.  W IODHLT,"    Orders for date: "_$$Y2K^LRX(DT)
  1.  W !
  1.  W IODHLB,"    Orders for date: "_$$Y2K^LRX(DT)
  1.  W !
  1.  S LRXYZ=0
  1.  W *7 H 1 W *7 H 1 W *7
  1.  ;
  1.  H 5
  1. QUITH ; 
  1.  D SCRNOFF^LRHYUTL ; Turn off screen variables
  1.  K LRDFN,PNM,LRSN,SSN,LRIDT,LRAA,LRAN,LRAD,LRHYCT
  1.  K LRNPZZX,LRNODUP,LRLLOC,LRTSTZ99,LRACC,LRCDT,LRDPF,LRI
  1.  K LRORD3,LRHYFIX,LRPLICK,LRPR,LRPRAC,LRQUIET,LRRB,LRSAMP,LRSND
  1.  K LRSS,LRST,LRSTATUS,LRSUB1,LRTIC,LRTIM,LRTN,LRTREA,LRTS,LRTSORU
  1.  K LRTST6,LRTT,LRUN,LRWLO,LRWLC,LRWRD,LRXYZ,LR3DTIME,LR3DTN
  1.  K LR3SN,LRDT0,LREAL,LRFUTURE,LRGOTIT,LRHOWDY,LRHYHOK,LRIENZZ
  1.  K LRNOTST,LRLBLBP,LRLLOC66,LRMAX2,LRNLT,LRNODUP,LRNONE,LRNPZZX,LRODT
  1.  K LRODT0,LRHYOK,LRORD24,LRORU3,LRPAST,LRPIX,LRAHEAD,LRCHK,LRHYCT,LRCOL99
  1.  K LRDT0,LRDUPT,LRHT1,LRIX,LROLLOC,LRX,LR3X
  1.  K VAIN
  1.  ;
  1.  ;
  1.  G VET
  1.  ;
  1.  ;
  1.  ;
  1. ORDCHK ; This block to be used for future version
  1.  QUIT
  1. LOG ; Howdy will default to the clerks judgement when multiple orders found.
  1.  Q:$G(LRSKIPNO)
  1.  ;
  1.  W !,"NO ORDERS"
  1.  ;
  1.  K LRDPF,PNM
  1.  D PT^LRX
  1.  D NOW^%DTC
  1.  I '$G(LRDFN) S ^TMP("LRHYDY",$J,"LR NO ORDERS",%)=$G(DFN) QUIT
  1.  S ^TMP("LRHYDY",$J,"LR NO ORDERS",%)=$G(PNM)_U_$G(^LR(LRDFN,.1))_U_$G(SSN)
  1.  QUIT
  1.  ;
  1.  ;
  1. LOG1 ; Howdy will default to the clerks judgement when multiple orders found.
  1.  K LRORD
  1.  W !,"MULTIPLE ORDERS"
  1.  K LRDPF,PNM
  1.  D PT^LRX
  1.  D NOW^%DTC
  1.  S ^TMP("LRHYDY",$J,"LR MULTIPLE ORDERS",%)=$G(PNM)_U_$G(^LR(LRDFN,.1))_U_$G(SSN)
  1.  K LRSKIPNO S LRSKIPNO=1
  1.  QUIT
  1. ORDERS ;
  1.  QUIT
  1. NOSCAN ;
  1.  QUIT
  1. DEL7 ;
  1.  QUIT