- LR382A ;HOIFO/JCH/LBC - Lab ADT Patch 382 Post Install routine ;April 06, 2011
- ;;5.2;LAB SERVICE;**382**;Sep 27, 1994;Build 188
- ;
- ; Reference to ^ORD(101,"B","VAFC ADT"* is supported by DBIA 4418
- ; Reference to ^HL(771 is supported by DBIA 10136
- ; Reference to ^HLCS(870 is supported by DBIA 1496
- ; Reference to ^DICN is supported by DBIA 10009
- ; Reference to ^DIE is supported by DBIA 10018
- ; Reference to ^DIK is supported by DBIA 10013
- ; Reference to ^DIR is supported by DBIA 10026
- ;
- EN ; Check answers to post install questions
- ;LBC- no post install questions
- ; INPUT
- ; XPDQUES("POST INSTALL2") (conditional - required if XPDQUES("POST INSTALL1")="I"
- ; values: valid TCP/IP address. Format: nn.nn.nn.nn
- ;
- ; XPDQUES("POST INSTALL3") (conditional - required if XPDQUES("POST INSTALL1")="I"
- ; values: valid TCP/IP port. Format: 1-9 numeric.
- ;
- ; User selected to install (or reinstall) patch
- ;lbc;I $G(XPDQUES("POST INSTALL2"))!$G(XPDQUES("POST INSTALL3")) D ENI
- ;lbc;Q
- ;
- ENI ; Patch 382 Post Install (Install)
- N DR,DA,DIC,DIE,DD,DO,STOP,TCPAD,TCPORT
- S STOP=0
- ;
- S PROTNM="VBECS ADT" F S PROTNM=$O(^ORD(101,"B",PROTNM)) Q:($E(PROTNM,1,9))'="VBECS ADT"!$G(STOP) D
- .Q:'(PROTNM["CLIENT")
- .S EVENT=$P($P(PROTNM,"-",2)," "),TOPROTNM="VAFC ADT-"_EVENT_" SERVER"
- .I $E(EVENT,2,3)>13 S STOP=1 Q
- .I EVENT["A08" D Q
- ..N A8SUF F A8SUF=" SERVER","-SDAM SERVER","-TSP SERVER","-SCHED SERVER" S TOPROTNM="VAFC ADT-"_EVENT_A8SUF D ADD(PROTNM,TOPROTNM)
- .D ADD(PROTNM,TOPROTNM)
- ;
- ; Unlink VBECS ADT-A08 ROUTER protocol from VAFC ADT-A08 SERVER protocol
- S TOPROTNM="VAFC ADT-A08 SERVER"
- S TOPROT=$O(^ORD(101,"B",TOPROTNM,"")) Q:'TOPROT
- S NEXT=0 F S NEXT=$O(^ORD(101,TOPROT,775,NEXT)) Q:'NEXT D
- .S PROT=$G(^ORD(101,TOPROT,775,NEXT,0)),PROTNM=$P($G(^ORD(101,PROT,0)),U)
- .Q:'(PROTNM["VBECS ADT-A08 ROUTER")
- .S DIK="^ORD(101,"_TOPROT_",775,",DA(1)=TOPROT,DA=NEXT D ^DIK K DIK,DA
- ;
- Q
- ;
- ADD(PROTNM,TOPROTNM) ; Add each PROTNM protocol as subscriber to TOPROTNM server protocol.
- ;
- N PROT,TOPROT,DUP
- S DUP=0
- S TOPROT=$O(^ORD(101,"B",TOPROTNM,"")),PROT=$O(^ORD(101,"B",PROTNM,""))
- N ND775,NXTSUB I $G(U)="" N U S U="^"
- S ND775=$G(^ORD(101,TOPROT,775,0)),NXTSUB=$P(ND775,U,3)+1
- S OTHSUBS=0 F S OTHSUBS=$O(^ORD(101,TOPROT,775,OTHSUBS)) Q:'OTHSUBS!$G(DUP) I ($G(^(OTHSUBS,0))=PROT) S DUP=1
- ; Don't add same protocol twice
- Q:$G(DUP)
- S DIC="^ORD(101,"_TOPROT_",775,",DIC("P")="101.0775PA",DINUM=NXTSUB,DA(1)=TOPROT,DIC(0)="L"
- S DIC("DR")=".01////"_PROT,X=DINUM
- D FILE^DICN K DR,DA,DIC
- Q
- ;
- ADDITEM(PROTNM,TOPROTNM) ; Add the PROTNM protocol as an ITEM to the TOPROTNM protocol
- N PROT,TOPROT,DUP
- S DUP=0
- S TOPROT=$O(^ORD(101,"B",TOPROTNM,"")),PROT=$O(^ORD(101,"B",PROTNM,""))
- N ND10,NXTITEM I $G(U)="" N U S U="^"
- S ND10=$G(^ORD(101,TOPROT,10,0)),NXTITEM=$P(ND10,U,3)+1
- S OTHITEMS=0 F S OTHITEMS=$O(^ORD(101,TOPROT,10,OTHITEMS)) Q:'OTHITEMS!$G(DUP) I ($G(^(OTHITEMS,0))=PROT) S DUP=1
- ; Don't add same item twice
- Q:$G(DUP)
- S DIC="^ORD(101,"_TOPROT_",10,",DIC("P")="101.01PA",DINUM=NXTITEM,DA(1)=TOPROT,DIC(0)="L"
- S DIC("DR")=".01////"_PROT,X=DINUM
- D FILE^DICN K DR,DA,DIC
- Q
- ;
- GETADD ; Prompt for TCP/IP Address
- ; Get TCP/IP Address for Logical Link, Port for Logical Link
- N TCPADD,TCPORT,LINK,DIE,DIR
- S DIR("A")="Enter TCP/IP Address of LRADT Logical Link"
- S DIR(0)="F^7:16^K:X'?1.3N1"".""1.3N1"".""1.3N1"".""1.3N"
- D ^DIR
- I +$G(Y)>0 S TCPADD=Y
- S DIR("A")="Enter TCP/IP Port of LRADT Logical Link"
- S DIR(0)="N^1:99999999"
- D ^DIR
- I +$G(Y)>0 S TCPORT=Y
- Q
- ;
- SETCP(ADD,PORT) ; Set TCP address and port into logical link
- Q:'ADD!'PORT
- S LINK=+$O(^HLCS(870,"B","LRADT","")) Q:'LINK
- S DIE="^HLCS(870,",DA=LINK,DR="400.01////"_ADD_";400.02////"_PORT
- D ^DIE
- Q
- ;
- SETFAC ; Set Facility into HL7 Application Parameter
- N FAC,APP
- S FAC=0 S FAC=$O(^LRO(67.9,FAC)) Q:'FAC
- S APP="" F APP="LRADT","LRADT TRIGGER" D
- .S APPNUM=$O(^HL(771,"B",APP,""))
- .N DIE,DA,DR
- .S DIE="^HL(771,",DA=APPNUM,DR="3////"_FAC
- .D ^DIE K DIE,DA,DR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR382A 4134 printed Jan 18, 2025@03:04:39 Page 2
- LR382A ;HOIFO/JCH/LBC - Lab ADT Patch 382 Post Install routine ;April 06, 2011
- +1 ;;5.2;LAB SERVICE;**382**;Sep 27, 1994;Build 188
- +2 ;
- +3 ; Reference to ^ORD(101,"B","VAFC ADT"* is supported by DBIA 4418
- +4 ; Reference to ^HL(771 is supported by DBIA 10136
- +5 ; Reference to ^HLCS(870 is supported by DBIA 1496
- +6 ; Reference to ^DICN is supported by DBIA 10009
- +7 ; Reference to ^DIE is supported by DBIA 10018
- +8 ; Reference to ^DIK is supported by DBIA 10013
- +9 ; Reference to ^DIR is supported by DBIA 10026
- +10 ;
- EN ; Check answers to post install questions
- +1 ;LBC- no post install questions
- +2 ; INPUT
- +3 ; XPDQUES("POST INSTALL2") (conditional - required if XPDQUES("POST INSTALL1")="I"
- +4 ; values: valid TCP/IP address. Format: nn.nn.nn.nn
- +5 ;
- +6 ; XPDQUES("POST INSTALL3") (conditional - required if XPDQUES("POST INSTALL1")="I"
- +7 ; values: valid TCP/IP port. Format: 1-9 numeric.
- +8 ;
- +9 ; User selected to install (or reinstall) patch
- +10 ;lbc;I $G(XPDQUES("POST INSTALL2"))!$G(XPDQUES("POST INSTALL3")) D ENI
- +11 ;lbc;Q
- +12 ;
- ENI ; Patch 382 Post Install (Install)
- +1 NEW DR,DA,DIC,DIE,DD,DO,STOP,TCPAD,TCPORT
- +2 SET STOP=0
- +3 ;
- +4 SET PROTNM="VBECS ADT"
- FOR
- SET PROTNM=$ORDER(^ORD(101,"B",PROTNM))
- if ($EXTRACT(PROTNM,1,9))'="VBECS ADT"!$GET(STOP)
- QUIT
- Begin DoDot:1
- +5 if '(PROTNM["CLIENT")
- QUIT
- +6 SET EVENT=$PIECE($PIECE(PROTNM,"-",2)," ")
- SET TOPROTNM="VAFC ADT-"_EVENT_" SERVER"
- +7 IF $EXTRACT(EVENT,2,3)>13
- SET STOP=1
- QUIT
- +8 IF EVENT["A08"
- Begin DoDot:2
- +9 NEW A8SUF
- FOR A8SUF=" SERVER","-SDAM SERVER","-TSP SERVER","-SCHED SERVER"
- SET TOPROTNM="VAFC ADT-"_EVENT_A8SUF
- DO ADD(PROTNM,TOPROTNM)
- End DoDot:2
- QUIT
- +10 DO ADD(PROTNM,TOPROTNM)
- End DoDot:1
- +11 ;
- +12 ; Unlink VBECS ADT-A08 ROUTER protocol from VAFC ADT-A08 SERVER protocol
- +13 SET TOPROTNM="VAFC ADT-A08 SERVER"
- +14 SET TOPROT=$ORDER(^ORD(101,"B",TOPROTNM,""))
- if 'TOPROT
- QUIT
- +15 SET NEXT=0
- FOR
- SET NEXT=$ORDER(^ORD(101,TOPROT,775,NEXT))
- if 'NEXT
- QUIT
- Begin DoDot:1
- +16 SET PROT=$GET(^ORD(101,TOPROT,775,NEXT,0))
- SET PROTNM=$PIECE($GET(^ORD(101,PROT,0)),U)
- +17 if '(PROTNM["VBECS ADT-A08 ROUTER")
- QUIT
- +18 SET DIK="^ORD(101,"_TOPROT_",775,"
- SET DA(1)=TOPROT
- SET DA=NEXT
- DO ^DIK
- KILL DIK,DA
- End DoDot:1
- +19 ;
- +20 QUIT
- +21 ;
- ADD(PROTNM,TOPROTNM) ; Add each PROTNM protocol as subscriber to TOPROTNM server protocol.
- +1 ;
- +2 NEW PROT,TOPROT,DUP
- +3 SET DUP=0
- +4 SET TOPROT=$ORDER(^ORD(101,"B",TOPROTNM,""))
- SET PROT=$ORDER(^ORD(101,"B",PROTNM,""))
- +5 NEW ND775,NXTSUB
- IF $GET(U)=""
- NEW U
- SET U="^"
- +6 SET ND775=$GET(^ORD(101,TOPROT,775,0))
- SET NXTSUB=$PIECE(ND775,U,3)+1
- +7 SET OTHSUBS=0
- FOR
- SET OTHSUBS=$ORDER(^ORD(101,TOPROT,775,OTHSUBS))
- if 'OTHSUBS!$GET(DUP)
- QUIT
- IF ($GET(^(OTHSUBS,0))=PROT)
- SET DUP=1
- +8 ; Don't add same protocol twice
- +9 if $GET(DUP)
- QUIT
- +10 SET DIC="^ORD(101,"_TOPROT_",775,"
- SET DIC("P")="101.0775PA"
- SET DINUM=NXTSUB
- SET DA(1)=TOPROT
- SET DIC(0)="L"
- +11 SET DIC("DR")=".01////"_PROT
- SET X=DINUM
- +12 DO FILE^DICN
- KILL DR,DA,DIC
- +13 QUIT
- +14 ;
- ADDITEM(PROTNM,TOPROTNM) ; Add the PROTNM protocol as an ITEM to the TOPROTNM protocol
- +1 NEW PROT,TOPROT,DUP
- +2 SET DUP=0
- +3 SET TOPROT=$ORDER(^ORD(101,"B",TOPROTNM,""))
- SET PROT=$ORDER(^ORD(101,"B",PROTNM,""))
- +4 NEW ND10,NXTITEM
- IF $GET(U)=""
- NEW U
- SET U="^"
- +5 SET ND10=$GET(^ORD(101,TOPROT,10,0))
- SET NXTITEM=$PIECE(ND10,U,3)+1
- +6 SET OTHITEMS=0
- FOR
- SET OTHITEMS=$ORDER(^ORD(101,TOPROT,10,OTHITEMS))
- if 'OTHITEMS!$GET(DUP)
- QUIT
- IF ($GET(^(OTHITEMS,0))=PROT)
- SET DUP=1
- +7 ; Don't add same item twice
- +8 if $GET(DUP)
- QUIT
- +9 SET DIC="^ORD(101,"_TOPROT_",10,"
- SET DIC("P")="101.01PA"
- SET DINUM=NXTITEM
- SET DA(1)=TOPROT
- SET DIC(0)="L"
- +10 SET DIC("DR")=".01////"_PROT
- SET X=DINUM
- +11 DO FILE^DICN
- KILL DR,DA,DIC
- +12 QUIT
- +13 ;
- GETADD ; Prompt for TCP/IP Address
- +1 ; Get TCP/IP Address for Logical Link, Port for Logical Link
- +2 NEW TCPADD,TCPORT,LINK,DIE,DIR
- +3 SET DIR("A")="Enter TCP/IP Address of LRADT Logical Link"
- +4 SET DIR(0)="F^7:16^K:X'?1.3N1"".""1.3N1"".""1.3N1"".""1.3N"
- +5 DO ^DIR
- +6 IF +$GET(Y)>0
- SET TCPADD=Y
- +7 SET DIR("A")="Enter TCP/IP Port of LRADT Logical Link"
- +8 SET DIR(0)="N^1:99999999"
- +9 DO ^DIR
- +10 IF +$GET(Y)>0
- SET TCPORT=Y
- +11 QUIT
- +12 ;
- SETCP(ADD,PORT) ; Set TCP address and port into logical link
- +1 if 'ADD!'PORT
- QUIT
- +2 SET LINK=+$ORDER(^HLCS(870,"B","LRADT",""))
- if 'LINK
- QUIT
- +3 SET DIE="^HLCS(870,"
- SET DA=LINK
- SET DR="400.01////"_ADD_";400.02////"_PORT
- +4 DO ^DIE
- +5 QUIT
- +6 ;
- SETFAC ; Set Facility into HL7 Application Parameter
- +1 NEW FAC,APP
- +2 SET FAC=0
- SET FAC=$ORDER(^LRO(67.9,FAC))
- if 'FAC
- QUIT
- +3 SET APP=""
- FOR APP="LRADT","LRADT TRIGGER"
- Begin DoDot:1
- +4 SET APPNUM=$ORDER(^HL(771,"B",APP,""))
- +5 NEW DIE,DA,DR
- +6 SET DIE="^HL(771,"
- SET DA=APPNUM
- SET DR="3////"_FAC
- +7 DO ^DIE
- KILL DIE,DA,DR
- End DoDot:1
- +8 QUIT