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