ALPBPARM ;SFVAMC/JC - Parameter Definitions ;05/02/2003 15:24
;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
N DEF,OPR,ZLNK
N ALPBSCRN,ALPBPARM,ALPBDIVE,ALPBDIVI,ALPBDIVP,ALPBINST,LNK,ERR,DIC,DIE,DA,DR,DIR
D Q3
S DIR(0)="Y",DIR("B")="YES" D ^DIR
I $D(DTOUT)!($D(DUOUT)) G OUT
S DEF=Y K DA,DIR,Y
I DEF=1 S ALPBPARM="PSB BKUP DEFAULT"
;Associate HL7 Logical Links with division(s)
I $G(ALPBPARM)']"" S ALPBPARM="PSB BKUP MACHINES"
S DIR(0)="S^A:Add a Logical Link;D:Delete a Logical Link"
S DIR("A")="OPERATION",DIR("B")="ADD"
D ^DIR
I $D(DTOUT)!($D(DUOUT)) G OUT
S OPR=Y K DA,DIR,Y
I DEF=1 D DLINKS G OUT
DIV ;division
N ALPBDIVP,ALPBDIVI,ALPBDIVE,ALPBINST
S ALPBDIVP=""
;note-parameter file requires institutions instead of divisions
;in DIV class
D Q1 S DIR(0)="PO^40.8:EMZ" D ^DIR
Q:$D(DTOUT)!($D(DUOUT))!($D(DIRUT))
S ALPBDIVI=+Y ;INTERNAL MEDICAL CENTER DIVISION
S ALPBDIVE=$P(Y,U,2) ;EXTERNAL MED CTR DIVISION
S ALPBINST=$P(Y(0),U,7) ;INSTITUTION FILE POINTER
I $G(ALPBINST)']"" W !,"Medical Ctr Divisions must be associated with an institution." G OUT
S ALPBDIVP="DIV.`"_ALPBINST ;PARAMETER FILE REFERENCE
I $G(ALPBDIVP)']"" W !,"Division information is required." G OUT
K DA,DIR,Y
D LINKS G DIV
Q
DLINKS ;What logical links for the DEFAULT parmeter?
K Y S X="BAR CODE MED ADMIN",DIC="^DIC(9.4,",DIC(0)="X",D="B" D IX^DIC
S ALPBPKG=+$P($G(Y),U,1)
I '$G(ALPBPKG) W !,"BAR CODE MED ADMIN MISSING FROM PACKAGE FILE." Q
S ALPBPKG="PKG.`"_ALPBPKG
K ZLNK
D GET(.ZLNK)
I '$D(ZLNK) W !,"No DEFAULT links defined for this package." Q:OPR="D"
W !,"The following DEFAULT links are associated with this package:"
S X="" F S X=$O(ZLNK("LINKS",X)) Q:X<1 D
. W !,$P(ZLNK("LINKS",X),U,2)
. I OPR="D" S ALPSCRN($P(ZLNK("LINKS",X),U,2),X)=ZLNK("LINKS",X)
F D Q:$G(DUOUT)!($G(DTOUT))!($G(DIRUT))
. D Q2
. I OPR="D" S DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
. S DIR("A")="Select WorkStation Link "
. S DIR(0)="PO^870:EMZ" D ^DIR
. I $G(DUOUT)!($G(DTOUT))!($G(DIRUT)) K DA,DIR,Y Q
. I Y>0 S RESULT=$$SET(ALPBPKG,$P(Y,U,2))
. I $G(RESULT)'<1 W !,RESULT
. K DA,DIR,Y
K ZLNK
Q
LINKS ;What logical links for a division?
W !,"The Institution associated with this division is ",$$NS^XUAF4(ALPBINST)
D GET(.LNK,ALPBDIVE,1)
I '$D(LNK),$G(OPR)="D" W !,"No links defined for this division." Q
W !,"The following links are associated with this division:"
S X="" F S X=$O(LNK("LINKS",X)) Q:X<1 D
. W !,$P(LNK("LINKS",X),U,2)
. I OPR="D" S ALPSCRN($P(LNK("LINKS",X),U,2),X)=LNK("LINKS",X)
K LNK
F D Q:$G(DUOUT)!($G(DTOUT))!($G(DIRUT))
. D Q2
. I OPR="D" S DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
. S DIR("A")="Select WorkStation Link "
. S DIR(0)="PO^870:EMZ" D ^DIR
. I $G(DUOUT)!($G(DTOUT))!($G(DIRUT)) K DA,DIR,Y Q
. I Y>0 S RESULT=$$SET(ALPBDIVP,$P(Y,U,2))
. I $G(RESULT)'<1 W !,RESULT
. K DA,DIR,Y,RESULT
Q
SET(ALPBDIVP,LINK) ;function to set or delete parameter for logical link
;and returns error response or zero
I OPR="A" D EN^XPAR(ALPBDIVP,ALPBPARM,LINK,LINK,.ERR) I ERR=0 W "...Added"
I OPR="D" D DEL^XPAR(ALPBDIVP,ALPBPARM,LINK,.ERR) I ERR=0 W "...Deleted" I $D(ALPSCRN(LINK)) K ALPSCRN(LINK)
Q ERR
GET(HLL,DIV,FLG,PR) ;Return HLL("LINKS") array for a given patient division
;HLL-HLL("links") array - pass by reference
;DIV- DIVISION (OPTIONAL)
;FLG-1=DON'T RETURN DEFAULT IF DIV IS EMPTY (OPTIONAL)
;PR-SUBSCRIBER PROTOCOL TO INCLUDE WITH THE HLL ARRAY (DEF=BCBU ORM RECV)
;or a default group if div null
I $G(PR)="" S PR="PSB BCBU ORM RECV"
I +$G(FLG)'=1 S FLG=0
N LST S LST=""
I $G(DIV)="" D G OUT
. K Y S X="BAR CODE MED ADMIN",DIC="^DIC(9.4,",DIC(0)="X",D="B" D IX^DIC
. S ALPBPKG=+$P($G(Y),U,1)
. Q:'ALPBPKG S ALPBPKG="PKG.`"_ALPBPKG
. D GETLST^XPAR(.LST,ALPBPKG,"PSB BKUP DEFAULT","E",.ERR)
. D GET1
N INST S INST=$$DV(DIV)
I INST']"" W !,"Unknown Institiution-please review Medical Ctr Division File." G OUT
D GETLST^XPAR(.LST,"DIV.`"_INST,"PSB BKUP MACHINES","E",.ERR)
I $O(LST(0))<1!(ERR) D
. Q:+FLG=1
. D GET(.HLL,"") ;Try to use default list if no results.
GET1 ;
I $O(LST(0)),ERR=0 N X S X=0 F S X=$O(LST(X)) Q:X<1 D
. Q:$P(LST(X),U,2)']""
. N LNK870 S LNK870=$P(LST(X),U,2) Q:$E(LNK870,1,2)="VA" ;don't init hospital
. S HLL("LINKS",X)=PR_U_$P(LST(X),U,2)
Q
DV(DV) ;take internal or external division and return institution
I +DV>0 S X="`"_DV
N Y,DIC,DA
S DIC=40.8,DIC(0)="MQZ",X=DV D ^DIC
I Y'<1 Q $P(Y(0),U,7)
Q ""
Q1 ;division help
S DIR("?")=" "
S DIR("?",1)="If you are associating different workstations with different"
S DIR("?",2)="divisions, you must choose a division first, then you will be asked"
S DIR("?",3)="to enter HL7 Logical Links that correspond to this division."
Q
Q2 ;Link help
S DIR("?")=" "
S DIR("?",1)="Each of the workstations you use for BCMA backups will"
S DIR("?",2)="have a fixed TCP/IP address assigned and an HL7 Logical"
S DIR("?",3)="Link associated with it. Now your workstations must be"
S DIR("?",4)="associated with each division you have defined. If you are not a multi-"
S DIR("?",5)="divisional facility, all workstations will be associated"
S DIR("?",6)="with only one facility."
Q
Q3 ;Ask Default
W !,"Do you want all backup data to go to the same group of"
W !,"backup devices regardless of the patient's division?"
Q
OUT ;EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HALPBPARM 5459 printed Oct 16, 2024@17:40:21 Page 2
ALPBPARM ;SFVAMC/JC - Parameter Definitions ;05/02/2003 15:24
+1 ;;3.0;BAR CODE MED ADMIN;**8**;Mar 2004
+2 NEW DEF,OPR,ZLNK
+3 NEW ALPBSCRN,ALPBPARM,ALPBDIVE,ALPBDIVI,ALPBDIVP,ALPBINST,LNK,ERR,DIC,DIE,DA,DR,DIR
+4 DO Q3
+5 SET DIR(0)="Y"
SET DIR("B")="YES"
DO ^DIR
+6 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO OUT
+7 SET DEF=Y
KILL DA,DIR,Y
+8 IF DEF=1
SET ALPBPARM="PSB BKUP DEFAULT"
+9 ;Associate HL7 Logical Links with division(s)
+10 IF $GET(ALPBPARM)']""
SET ALPBPARM="PSB BKUP MACHINES"
+11 SET DIR(0)="S^A:Add a Logical Link;D:Delete a Logical Link"
+12 SET DIR("A")="OPERATION"
SET DIR("B")="ADD"
+13 DO ^DIR
+14 IF $DATA(DTOUT)!($DATA(DUOUT))
GOTO OUT
+15 SET OPR=Y
KILL DA,DIR,Y
+16 IF DEF=1
DO DLINKS
GOTO OUT
DIV ;division
+1 NEW ALPBDIVP,ALPBDIVI,ALPBDIVE,ALPBINST
+2 SET ALPBDIVP=""
+3 ;note-parameter file requires institutions instead of divisions
+4 ;in DIV class
+5 DO Q1
SET DIR(0)="PO^40.8:EMZ"
DO ^DIR
+6 if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIRUT))
QUIT
+7 ;INTERNAL MEDICAL CENTER DIVISION
SET ALPBDIVI=+Y
+8 ;EXTERNAL MED CTR DIVISION
SET ALPBDIVE=$PIECE(Y,U,2)
+9 ;INSTITUTION FILE POINTER
SET ALPBINST=$PIECE(Y(0),U,7)
+10 IF $GET(ALPBINST)']""
WRITE !,"Medical Ctr Divisions must be associated with an institution."
GOTO OUT
+11 ;PARAMETER FILE REFERENCE
SET ALPBDIVP="DIV.`"_ALPBINST
+12 IF $GET(ALPBDIVP)']""
WRITE !,"Division information is required."
GOTO OUT
+13 KILL DA,DIR,Y
+14 DO LINKS
GOTO DIV
+15 QUIT
DLINKS ;What logical links for the DEFAULT parmeter?
+1 KILL Y
SET X="BAR CODE MED ADMIN"
SET DIC="^DIC(9.4,"
SET DIC(0)="X"
SET D="B"
DO IX^DIC
+2 SET ALPBPKG=+$PIECE($GET(Y),U,1)
+3 IF '$GET(ALPBPKG)
WRITE !,"BAR CODE MED ADMIN MISSING FROM PACKAGE FILE."
QUIT
+4 SET ALPBPKG="PKG.`"_ALPBPKG
+5 KILL ZLNK
+6 DO GET(.ZLNK)
+7 IF '$DATA(ZLNK)
WRITE !,"No DEFAULT links defined for this package."
if OPR="D"
QUIT
+8 WRITE !,"The following DEFAULT links are associated with this package:"
+9 SET X=""
FOR
SET X=$ORDER(ZLNK("LINKS",X))
if X<1
QUIT
Begin DoDot:1
+10 WRITE !,$PIECE(ZLNK("LINKS",X),U,2)
+11 IF OPR="D"
SET ALPSCRN($PIECE(ZLNK("LINKS",X),U,2),X)=ZLNK("LINKS",X)
End DoDot:1
+12 FOR
Begin DoDot:1
+13 DO Q2
+14 IF OPR="D"
SET DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
+15 SET DIR("A")="Select WorkStation Link "
+16 SET DIR(0)="PO^870:EMZ"
DO ^DIR
+17 IF $GET(DUOUT)!($GET(DTOUT))!($GET(DIRUT))
KILL DA,DIR,Y
QUIT
+18 IF Y>0
SET RESULT=$$SET(ALPBPKG,$PIECE(Y,U,2))
+19 IF $GET(RESULT)'<1
WRITE !,RESULT
+20 KILL DA,DIR,Y
End DoDot:1
if $GET(DUOUT)!($GET(DTOUT))!($GET(DIRUT))
QUIT
+21 KILL ZLNK
+22 QUIT
LINKS ;What logical links for a division?
+1 WRITE !,"The Institution associated with this division is ",$$NS^XUAF4(ALPBINST)
+2 DO GET(.LNK,ALPBDIVE,1)
+3 IF '$DATA(LNK)
IF $GET(OPR)="D"
WRITE !,"No links defined for this division."
QUIT
+4 WRITE !,"The following links are associated with this division:"
+5 SET X=""
FOR
SET X=$ORDER(LNK("LINKS",X))
if X<1
QUIT
Begin DoDot:1
+6 WRITE !,$PIECE(LNK("LINKS",X),U,2)
+7 IF OPR="D"
SET ALPSCRN($PIECE(LNK("LINKS",X),U,2),X)=LNK("LINKS",X)
End DoDot:1
+8 KILL LNK
+9 FOR
Begin DoDot:1
+10 DO Q2
+11 IF OPR="D"
SET DIR("S")="I $D(ALPSCRN($P(^HLCS(870,+Y,0),U,1)))"
+12 SET DIR("A")="Select WorkStation Link "
+13 SET DIR(0)="PO^870:EMZ"
DO ^DIR
+14 IF $GET(DUOUT)!($GET(DTOUT))!($GET(DIRUT))
KILL DA,DIR,Y
QUIT
+15 IF Y>0
SET RESULT=$$SET(ALPBDIVP,$PIECE(Y,U,2))
+16 IF $GET(RESULT)'<1
WRITE !,RESULT
+17 KILL DA,DIR,Y,RESULT
End DoDot:1
if $GET(DUOUT)!($GET(DTOUT))!($GET(DIRUT))
QUIT
+18 QUIT
SET(ALPBDIVP,LINK) ;function to set or delete parameter for logical link
+1 ;and returns error response or zero
+2 IF OPR="A"
DO EN^XPAR(ALPBDIVP,ALPBPARM,LINK,LINK,.ERR)
IF ERR=0
WRITE "...Added"
+3 IF OPR="D"
DO DEL^XPAR(ALPBDIVP,ALPBPARM,LINK,.ERR)
IF ERR=0
WRITE "...Deleted"
IF $DATA(ALPSCRN(LINK))
KILL ALPSCRN(LINK)
+4 QUIT ERR
GET(HLL,DIV,FLG,PR) ;Return HLL("LINKS") array for a given patient division
+1 ;HLL-HLL("links") array - pass by reference
+2 ;DIV- DIVISION (OPTIONAL)
+3 ;FLG-1=DON'T RETURN DEFAULT IF DIV IS EMPTY (OPTIONAL)
+4 ;PR-SUBSCRIBER PROTOCOL TO INCLUDE WITH THE HLL ARRAY (DEF=BCBU ORM RECV)
+5 ;or a default group if div null
+6 IF $GET(PR)=""
SET PR="PSB BCBU ORM RECV"
+7 IF +$GET(FLG)'=1
SET FLG=0
+8 NEW LST
SET LST=""
+9 IF $GET(DIV)=""
Begin DoDot:1
+10 KILL Y
SET X="BAR CODE MED ADMIN"
SET DIC="^DIC(9.4,"
SET DIC(0)="X"
SET D="B"
DO IX^DIC
+11 SET ALPBPKG=+$PIECE($GET(Y),U,1)
+12 if 'ALPBPKG
QUIT
SET ALPBPKG="PKG.`"_ALPBPKG
+13 DO GETLST^XPAR(.LST,ALPBPKG,"PSB BKUP DEFAULT","E",.ERR)
+14 DO GET1
End DoDot:1
GOTO OUT
+15 NEW INST
SET INST=$$DV(DIV)
+16 IF INST']""
WRITE !,"Unknown Institiution-please review Medical Ctr Division File."
GOTO OUT
+17 DO GETLST^XPAR(.LST,"DIV.`"_INST,"PSB BKUP MACHINES","E",.ERR)
+18 IF $ORDER(LST(0))<1!(ERR)
Begin DoDot:1
+19 if +FLG=1
QUIT
+20 ;Try to use default list if no results.
DO GET(.HLL,"")
End DoDot:1
GET1 ;
+1 IF $ORDER(LST(0))
IF ERR=0
NEW X
SET X=0
FOR
SET X=$ORDER(LST(X))
if X<1
QUIT
Begin DoDot:1
+2 if $PIECE(LST(X),U,2)']""
QUIT
+3 ;don't init hospital
NEW LNK870
SET LNK870=$PIECE(LST(X),U,2)
if $EXTRACT(LNK870,1,2)="VA"
QUIT
+4 SET HLL("LINKS",X)=PR_U_$PIECE(LST(X),U,2)
End DoDot:1
+5 QUIT
DV(DV) ;take internal or external division and return institution
+1 IF +DV>0
SET X="`"_DV
+2 NEW Y,DIC,DA
+3 SET DIC=40.8
SET DIC(0)="MQZ"
SET X=DV
DO ^DIC
+4 IF Y'<1
QUIT $PIECE(Y(0),U,7)
+5 QUIT ""
Q1 ;division help
+1 SET DIR("?")=" "
+2 SET DIR("?",1)="If you are associating different workstations with different"
+3 SET DIR("?",2)="divisions, you must choose a division first, then you will be asked"
+4 SET DIR("?",3)="to enter HL7 Logical Links that correspond to this division."
+5 QUIT
Q2 ;Link help
+1 SET DIR("?")=" "
+2 SET DIR("?",1)="Each of the workstations you use for BCMA backups will"
+3 SET DIR("?",2)="have a fixed TCP/IP address assigned and an HL7 Logical"
+4 SET DIR("?",3)="Link associated with it. Now your workstations must be"
+5 SET DIR("?",4)="associated with each division you have defined. If you are not a multi-"
+6 SET DIR("?",5)="divisional facility, all workstations will be associated"
+7 SET DIR("?",6)="with only one facility."
+8 QUIT
Q3 ;Ask Default
+1 WRITE !,"Do you want all backup data to go to the same group of"
+2 WRITE !,"backup devices regardless of the patient's division?"
+3 QUIT
OUT ;EXIT
+1 QUIT
