ALPBIN ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;07/06/16 7:06am
;;3.0;BAR CODE MED ADMIN;**8,73,87,115**;Mar 2004;Build 3
;
; Reference/IA
; DPT/10035
; DIC(42/10039
; DIC(42/2440
;
;*87 - Fix VistA Init by DIV option where Clinic orders will check if
; they point to DIV requested.
Q
OPT ;Entry point for the option
;Select all or by Division
ALL ;Ask if the user want to send to all divisions
K DTOUT,DUOUT,DIRUT,DIROUT,DIR,ALPALL,ALPWKS,ALPDIV,ALPBDVN
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Enter Yes or No"
S DIR("A",1)="Include all Divisions"
D ^DIR
I $D(DIRUT) G EXIT
S ALPALL=+Y
;I +ALPALL>0 D QUE
I ALPALL'>0 D DIV
;I +ALPALL'>0!(+ALPWKS>0) D QUE
D QUE
;
EXIT ;
K ALPB,ALPBI,ALPBJ,ALPCN,ALDFN,ALPMDT,ALPML,ALPORDR,MSCTR,MSH,ORC
K PID,PV1,ALPHLL,ALPALL,DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,ALPDIV
K ALPTST,ALPSTOP,ALPOK,ZTSAVE,ALPCNI,ALPCNT,ALP,ALPDVN,ALPHLINI
Q
;
DIV K ALPHLL,DIR,ALPDIV,DTOUT,DUOUT,DIRUT,DIROUT,ALPHLINI
S DIR(0)="PO^40.8:EMZ"
S DIR("A",1)="Enter the division that you would like to"
S DIR("A",2)="initialize"
D ^DIR
I $D(DIRUT)!(+Y'>0) S ALPDIV="" Q
S ALPDIV=$P(Y,U,1),ALPDVN=$P(Y,U,2)
D GET^ALPBPARM(.ALPHLL,ALPDIV)
I '$D(ALPHLL) W !,"No workstations defined with "_ALPDVN G DIV
ALLWKS ;If no then set allow the user to select the workstation
K DTOUT,DUOUT,DIRUT,DIROUT,DIR
S DIR(0)="Y",DIR("B")="YES"
S DIR("A")="Enter Yes or No"
S DIR("A",1)="Include all workstations for the "_ALPDVN_" Division"
D ^DIR
I $D(DIRUT) G DIV
S ALPWKS=+Y
I +ALPWKS>0 Q
;
WRKSTN ;Now select which workstations for the division to be initialized
K ALPSCRN,ALPBANS
;Set up screen
S ALP=0 F S ALP=$O(ALPHLL("LINKS",ALP)) Q:+ALP'>0 D
. S ALPSCRN($P(ALPHLL("LINKS",ALP),U,2),ALP)=ALPHLL("LINKS",ALP)
K ALPHLL
F D LP Q:$D(DIRUT)
;I $D(DIRUT)!$D(ALPHLL) W !!,"No Selected Workstations" G ALLWKS
I '$D(ALPBANS)!$D(ALPHLL) W !!,"No Selected Workstations" G ALLWKS
Q:'$D(ALPBANS)
S ALP="",ALPCNT=1
F S ALP=$O(ALPBANS(ALP)) Q:ALP="" D
. S ALPHLL("LINKS",ALPCNT)=ALPSCRN(ALP,$O(ALPSCRN(ALP,0)))
. S ALPHLINI(ALPHLL("LINKS",ALPCNT))=""
. S ALPCNT=ALPCNT+1
K ALPSCRN,ALPBANS
Q
;
LP ;Multiple entries
K DIR,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="PO^870:EMZ",DIR("A")="Select WorkStation Link "
S DIR("?")="Answer with WorkStation Link to update "
S DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
D ^DIR
Q:$D(DIRUT)
S ALPBANS($P(Y,U,2),+Y)=""
W #,!!,"Selected Workstations",!!
S ALPB=""
F ALP=1:1 S ALPB=$O(ALPBANS(ALPB)) Q:ALPB="" D
.W ?$S(ALP#2:1,1:40),ALPB
.W:ALP#2'>0 !
Q
;
QUE ;Que the job
S ZTRTN="EN^ALPBIN"
S ZTDESC="PSB - Initialize the Contingency Workstation"
S ZTIO="",ZTSAVE("ALPWKS")="",ZTSAVE("ALPDIV")=""
I $D(ALPHLL) S ZTSAVE("ALPHLL(")=""
I $D(ALPHLINI) S ZTSAVE("ALPHLINI(")=""
D ^%ZTLOAD
W:$D(ZTSK) !,ZTSK
K ZTIO,ZTDESC,ZTRTN,ZTSK
Q
EN ;Loop through the inpatient list.
S ALPDTS=$$FMTE^XLFDT($$NOW^XLFDT)
I +$G(ALPDIV)'>0 S ALPDIV=0
S ALPSTOP=0,ALPOK=1
N ALPDIV0 S ALPDIV0=ALPDIV ;save Div selected *87
S ALPCN=""
F S ALPCN=$O(^DPT("CN",ALPCN)) Q:ALPCN=""!(ALPSTOP) D
. ;DIVISION SCREEN HERE
. S ALPCNI=$O(^DIC(42,"B",ALPCN,0))
. Q:+ALPCNI'>0 ;Quit if I can't decipher the Ward Location
. S ALPTST=$P($G(^DIC(42,ALPCNI,0)),U,11)
. I +ALPDIV&(ALPDIV'=ALPTST) Q
. S ALPSTOP=$$S^%ZTLOAD()
. Q:ALPSTOP
. S ALDFN=0
. F S ALDFN=$O(^DPT("CN",ALPCN,ALDFN)) Q:+ALDFN'>0!(ALPSTOP) D PAT^ALPBIND(ALPDIV0)
;
N ALPNOWCL S ALPNOWCL=$$NOW^XLFDT()
D UDCLIN^ALPBIND(ALPNOWCL,ALPDIV0) ;pass Div selected *87
D IVCLIN^ALPBIND(ALPNOWCL,ALPDIV0) ;pass Div selected *87
;
K XQA,XQAMSG
S ALPDTE=$$FMTE^XLFDT($$NOW^XLFDT)
S XQA(DUZ)=""
S XQAMSG="BCBU WORKSTATION INIT Started "_ALPDTS_" and finished "_ALPDTE_". "
;_ALPBK_" entries sent."
D SETUP^XQALERT
K ALPDTS,ALPDTE,ALPCNT
D EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBIN 3976 printed Apr 09, 2024@20:44:35 Page 2
ALPBIN ;OIFO-DALLAS/SED/KC/MW BCMA-BCBU INPT TO HL7 INIT ;07/06/16 7:06am
+1 ;;3.0;BAR CODE MED ADMIN;**8,73,87,115**;Mar 2004;Build 3
+2 ;
+3 ; Reference/IA
+4 ; DPT/10035
+5 ; DIC(42/10039
+6 ; DIC(42/2440
+7 ;
+8 ;*87 - Fix VistA Init by DIV option where Clinic orders will check if
+9 ; they point to DIV requested.
+10 QUIT
OPT ;Entry point for the option
+1 ;Select all or by Division
ALL ;Ask if the user want to send to all divisions
+1 KILL DTOUT,DUOUT,DIRUT,DIROUT,DIR,ALPALL,ALPWKS,ALPDIV,ALPBDVN
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 SET DIR("A")="Enter Yes or No"
+4 SET DIR("A",1)="Include all Divisions"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
GOTO EXIT
+7 SET ALPALL=+Y
+8 ;I +ALPALL>0 D QUE
+9 IF ALPALL'>0
DO DIV
+10 ;I +ALPALL'>0!(+ALPWKS>0) D QUE
+11 DO QUE
+12 ;
EXIT ;
+1 KILL ALPB,ALPBI,ALPBJ,ALPCN,ALDFN,ALPMDT,ALPML,ALPORDR,MSCTR,MSH,ORC
+2 KILL PID,PV1,ALPHLL,ALPALL,DIR,Y,DTOUT,DUOUT,DIRUT,DIROUT,ALPDIV
+3 KILL ALPTST,ALPSTOP,ALPOK,ZTSAVE,ALPCNI,ALPCNT,ALP,ALPDVN,ALPHLINI
+4 QUIT
+5 ;
DIV KILL ALPHLL,DIR,ALPDIV,DTOUT,DUOUT,DIRUT,DIROUT,ALPHLINI
+1 SET DIR(0)="PO^40.8:EMZ"
+2 SET DIR("A",1)="Enter the division that you would like to"
+3 SET DIR("A",2)="initialize"
+4 DO ^DIR
+5 IF $DATA(DIRUT)!(+Y'>0)
SET ALPDIV=""
QUIT
+6 SET ALPDIV=$PIECE(Y,U,1)
SET ALPDVN=$PIECE(Y,U,2)
+7 DO GET^ALPBPARM(.ALPHLL,ALPDIV)
+8 IF '$DATA(ALPHLL)
WRITE !,"No workstations defined with "_ALPDVN
GOTO DIV
ALLWKS ;If no then set allow the user to select the workstation
+1 KILL DTOUT,DUOUT,DIRUT,DIROUT,DIR
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 SET DIR("A")="Enter Yes or No"
+4 SET DIR("A",1)="Include all workstations for the "_ALPDVN_" Division"
+5 DO ^DIR
+6 IF $DATA(DIRUT)
GOTO DIV
+7 SET ALPWKS=+Y
+8 IF +ALPWKS>0
QUIT
+9 ;
WRKSTN ;Now select which workstations for the division to be initialized
+1 KILL ALPSCRN,ALPBANS
+2 ;Set up screen
+3 SET ALP=0
FOR
SET ALP=$ORDER(ALPHLL("LINKS",ALP))
if +ALP'>0
QUIT
Begin DoDot:1
+4 SET ALPSCRN($PIECE(ALPHLL("LINKS",ALP),U,2),ALP)=ALPHLL("LINKS",ALP)
End DoDot:1
+5 KILL ALPHLL
+6 FOR
DO LP
if $DATA(DIRUT)
QUIT
+7 ;I $D(DIRUT)!$D(ALPHLL) W !!,"No Selected Workstations" G ALLWKS
+8 IF '$DATA(ALPBANS)!$DATA(ALPHLL)
WRITE !!,"No Selected Workstations"
GOTO ALLWKS
+9 if '$DATA(ALPBANS)
QUIT
+10 SET ALP=""
SET ALPCNT=1
+11 FOR
SET ALP=$ORDER(ALPBANS(ALP))
if ALP=""
QUIT
Begin DoDot:1
+12 SET ALPHLL("LINKS",ALPCNT)=ALPSCRN(ALP,$ORDER(ALPSCRN(ALP,0)))
+13 SET ALPHLINI(ALPHLL("LINKS",ALPCNT))=""
+14 SET ALPCNT=ALPCNT+1
End DoDot:1
+15 KILL ALPSCRN,ALPBANS
+16 QUIT
+17 ;
LP ;Multiple entries
+1 KILL DIR,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="PO^870:EMZ"
SET DIR("A")="Select WorkStation Link "
+3 SET DIR("?")="Answer with WorkStation Link to update "
+4 SET DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
+5 DO ^DIR
+6 if $DATA(DIRUT)
QUIT
+7 SET ALPBANS($PIECE(Y,U,2),+Y)=""
+8 WRITE #,!!,"Selected Workstations",!!
+9 SET ALPB=""
+10 FOR ALP=1:1
SET ALPB=$ORDER(ALPBANS(ALPB))
if ALPB=""
QUIT
Begin DoDot:1
+11 WRITE ?$SELECT(ALP#2:1,1:40),ALPB
+12 if ALP#2'>0
WRITE !
End DoDot:1
+13 QUIT
+14 ;
QUE ;Que the job
+1 SET ZTRTN="EN^ALPBIN"
+2 SET ZTDESC="PSB - Initialize the Contingency Workstation"
+3 SET ZTIO=""
SET ZTSAVE("ALPWKS")=""
SET ZTSAVE("ALPDIV")=""
+4 IF $DATA(ALPHLL)
SET ZTSAVE("ALPHLL(")=""
+5 IF $DATA(ALPHLINI)
SET ZTSAVE("ALPHLINI(")=""
+6 DO ^%ZTLOAD
+7 if $DATA(ZTSK)
WRITE !,ZTSK
+8 KILL ZTIO,ZTDESC,ZTRTN,ZTSK
+9 QUIT
EN ;Loop through the inpatient list.
+1 SET ALPDTS=$$FMTE^XLFDT($$NOW^XLFDT)
+2 IF +$GET(ALPDIV)'>0
SET ALPDIV=0
+3 SET ALPSTOP=0
SET ALPOK=1
+4 ;save Div selected *87
NEW ALPDIV0
SET ALPDIV0=ALPDIV
+5 SET ALPCN=""
+6 FOR
SET ALPCN=$ORDER(^DPT("CN",ALPCN))
if ALPCN=""!(ALPSTOP)
QUIT
Begin DoDot:1
+7 ;DIVISION SCREEN HERE
+8 SET ALPCNI=$ORDER(^DIC(42,"B",ALPCN,0))
+9 ;Quit if I can't decipher the Ward Location
if +ALPCNI'>0
QUIT
+10 SET ALPTST=$PIECE($GET(^DIC(42,ALPCNI,0)),U,11)
+11 IF +ALPDIV&(ALPDIV'=ALPTST)
QUIT
+12 SET ALPSTOP=$$S^%ZTLOAD()
+13 if ALPSTOP
QUIT
+14 SET ALDFN=0
+15 FOR
SET ALDFN=$ORDER(^DPT("CN",ALPCN,ALDFN))
if +ALDFN'>0!(ALPSTOP)
QUIT
DO PAT^ALPBIND(ALPDIV0)
End DoDot:1
+16 ;
+17 NEW ALPNOWCL
SET ALPNOWCL=$$NOW^XLFDT()
+18 ;pass Div selected *87
DO UDCLIN^ALPBIND(ALPNOWCL,ALPDIV0)
+19 ;pass Div selected *87
DO IVCLIN^ALPBIND(ALPNOWCL,ALPDIV0)
+20 ;
+21 KILL XQA,XQAMSG
+22 SET ALPDTE=$$FMTE^XLFDT($$NOW^XLFDT)
+23 SET XQA(DUZ)=""
+24 SET XQAMSG="BCBU WORKSTATION INIT Started "_ALPDTS_" and finished "_ALPDTE_". "
+25 ;_ALPBK_" entries sent."
+26 DO SETUP^XQALERT
+27 KILL ALPDTS,ALPDTE,ALPCNT
+28 DO EXIT
+29 QUIT
