DGY994PO ; ALB/CNF/CMF - UTILITY TO CREATE CERNER LOGICAL LINK ; 10-03-2019
;;5.3;Registration;**1005**;Aug 13, 1993;Build 57
;
ENV ; Entry point for environment check
S XPDABORT=""
D PROGCHK(.XPDABORT) I XPDABORT=2 Q
D CRNRCHK(.XPDABORT) I XPDABORT=2 Q
I XPDABORT="" K XPDABORT
Q
;
PRE ; Entry point for pre install
Q
PROGCHK(XPDABORT) ;checks for necessary programmer variables
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
. D BMES^XPDUTL("******")
. D MES^XPDUTL("Your programming variables are not set up properly.")
. D MES^XPDUTL("Installation aborted.")
. D MES^XPDUTL("******")
. S XPDABORT=2
Q
;
CRNRCHK(XPDABORT) ;checks CERNER entry in Institution file. Post init will fail if missing.
I $$FIND1^DIC(4,"","MX","CERNER")=0 DO
. D BMES^XPDUTL("******")
. D MES^XPDUTL("There is no CERNER entry in the Institution file (#4).")
. D MES^XPDUTL("This entry is necessary for the Logical Link file (#870) update in this patch.")
. D MES^XPDUTL("Contact Customer Service for instructions to install this entry then try again.")
. D MES^XPDUTL("Installation aborted.")
. D MES^XPDUTL("******")
. S XPDABORT=2
Q
;
POST ; Entry point post install
;set up logical link
N DGX,DGABRT,DGPORT,DGLNK,DGOLD,DGNEW,DGPCE,DGNAME
;
S DGABRT=0 ;Abort Flag: 1=Abort Setup, 0=Continue Setup
F DGX="BUG","CHK","PORT","870","FIN" D @DGX Q:DGABRT
D:DGABRT ABRT
;
Q
;
BUG ; Before this patch, a category II flag could be inactivated without
; inactivating patient flag assignments for the inactive category II flag.
; That bug is fixed and this code cleans up the patient flag assignments.
;
D BMES^XPDUTL("Inactivate all active patient record flag assignment records in the")
D MES^XPDUTL("PRF ASSIGNMENT (#26.13) file when records are associated with an")
D MES^XPDUTL("inactive category II patient flag.")
;
; Loop through the 0 records in DGPF(26.11
; Because of previous bug, index "ASTAT" is not correct.
; Inactive entries may appear as active in "ASTAT" index.
;
N FLG,FLGNM,MSG,X
S FLG=0
F S FLG=$O(^DGPF(26.11,FLG)) Q:'FLG D
. S X=$G(^DGPF(26.11,FLG,0)) I '$L(X) Q ;record doesn't exist
. I $P(X,"^",2) Q ;record is active
. ;
. S FLGNM=$P(X,"^",1)
. S MSG="Second inactivation, see patch DG*5.3*994"
. D DEACT^DGPFXCRN(FLG,FLGNM,MSG) ;inactivate a second time for audit purposes
. S DA=FLG,DIK="^DGPF(26.11," D IX^DIK ;correct index for this entry
. ;
. ; Patient flag assignments are not inactivated as part of set logic because patient flag
. ; status isn't changing. Flag status was set to inactive and code is re-setting to inactive.
. ; Call DGPFDD to inactivate patient flag assignments.
. D INACT^DGPFDD(FLG,0,26.11,DUZ)
;
D MES^XPDUTL("Patient Record Flag entries cleaned up.")
Q
;
CHK ; Check for existing logical link
N X,Y,Z,J
S DGLNK="VACRNR"
S X=$$FIND1^DIC(870,"","MX",DGLNK) I X>0 D
. D BMES^XPDUTL("A Logical Link for "_DGLNK_" already exists and will be overwritten.")
;
S DGPCE=".01,.02,.08,4.5,2,3,21,200.021,200.05,200.08,400.02,400.03,400.04,400.07"
F J=1:1:14 S $P(DGOLD,",",J)=$$GET1^DIQ(870,X,$P(DGPCE,",",J))
;
Q
;
PORT ; KIDS has prompted user for port number, set port variable DGPORT
S Y=$G(XPDQUES("POSPORT"))
I (Y="")!(Y="^") S DGABRT=1 Q
;
I Y'?1N.N S DGABRT=1 Q
S DGPORT=$G(Y)
Q
;
870 ; Create HL7 Logical Link
N ERR,FDA,X,J
;
; Set up the logical link
K FDA
S FDA(1,870,"?+1,",.01)=DGLNK ;Node
S:$P($G(DGOLD),",",2)'="CERNER" FDA(1,870,"?+1,",.02)="CERNER" ;Institution
S FDA(1,870,"?+1,",.08)="hc-vdif-ent.domain.ext" ;DNS Domain
S FDA(1,870,"?+1,",4.5)=1 ;Autostart
S FDA(1,870,"?+1,",2)="TCP" ;LLP Type
S FDA(1,870,"?+1,",3)="NC" ;Device Type
S FDA(1,870,"?+1,",21)=10 ;Queue Size
S FDA(1,870,"?+1,",200.021)="R" ;Exceed Re-transmit Action
S FDA(1,870,"?+1,",200.05)=20 ;ACK timeout
S FDA(1,870,"?+1,",200.08)=2.3 ;Protocol ID Version
S FDA(1,870,"?+1,",400.02)=DGPORT ;TCP/IP Port
S FDA(1,870,"?+1,",400.03)="C" ;TCP/IP Service Type
S FDA(1,870,"?+1,",400.04)="N" ;Persistent
S FDA(1,870,"?+1,",400.07)="Y" ;Say HELO
;
D UPDATE^DIE("E","FDA(1)","","ERR")
I $D(ERR) D Q
. D BMES^XPDUTL("Unable to file a logical Link for "_DGLNK_".")
. S DGABRT=1
;
; If there were previous values for the logical link, document what was changed.
I '$L($G(DGOLD)) Q ;Quit if DGOLD does not have a value
;
S DGNAME="Node,Institution,DNS Domain,Autostart,LLP Type,Device Type,Queue Size,"
S DGNAME=DGNAME_"Exceed Re-transmit Action,ACK timeout,Protocol ID Version,"
S DGNAME=DGNAME_"TCP/IP Port,TCP/IP Service Type,Persistent,Say HELO"
S DGNEW="VACRNR,CERNER,vaauscluhshhl7rtr201.aac.domain.ext,1,TCP,NC,10,R,20,2.3,"
S DGNEW=DGNEW_DGPORT_",C,N,Y"
;
S X="Summary of changes to logical link "_DGLNK D BMES^XPDUTL(X)
F J=1:1:14 I '($P(DGOLD,",",J)=$P(DGNEW,",",J)) D
. S X=" Value changed for field: "_$P(DGNAME,",",J) D MES^XPDUTL(X)
. S X=" OLD: "_$P(DGOLD,",",J) D MES^XPDUTL(X)
. S X=" NEW: "_$P(DGNEW,",",J) D MES^XPDUTL(X)
Q
;
FIN ;
D BMES^XPDUTL("Logical Link Setup Complete")
Q
;
ABRT ;
D BMES^XPDUTL("Logical Link Setup Aborted")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGY994PO 5764 printed Dec 13, 2024@03:00:07 Page 2
DGY994PO ; ALB/CNF/CMF - UTILITY TO CREATE CERNER LOGICAL LINK ; 10-03-2019
+1 ;;5.3;Registration;**1005**;Aug 13, 1993;Build 57
+2 ;
ENV ; Entry point for environment check
+1 SET XPDABORT=""
+2 DO PROGCHK(.XPDABORT)
IF XPDABORT=2
QUIT
+3 DO CRNRCHK(.XPDABORT)
IF XPDABORT=2
QUIT
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
PRE ; Entry point for pre install
+1 QUIT
PROGCHK(XPDABORT) ;checks for necessary programmer variables
+1 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+2 DO BMES^XPDUTL("******")
+3 DO MES^XPDUTL("Your programming variables are not set up properly.")
+4 DO MES^XPDUTL("Installation aborted.")
+5 DO MES^XPDUTL("******")
+6 SET XPDABORT=2
End DoDot:1
+7 QUIT
+8 ;
CRNRCHK(XPDABORT) ;checks CERNER entry in Institution file. Post init will fail if missing.
+1 IF $$FIND1^DIC(4,"","MX","CERNER")=0
Begin DoDot:1
+2 DO BMES^XPDUTL("******")
+3 DO MES^XPDUTL("There is no CERNER entry in the Institution file (#4).")
+4 DO MES^XPDUTL("This entry is necessary for the Logical Link file (#870) update in this patch.")
+5 DO MES^XPDUTL("Contact Customer Service for instructions to install this entry then try again.")
+6 DO MES^XPDUTL("Installation aborted.")
+7 DO MES^XPDUTL("******")
+8 SET XPDABORT=2
End DoDot:1
+9 QUIT
+10 ;
POST ; Entry point post install
+1 ;set up logical link
+2 NEW DGX,DGABRT,DGPORT,DGLNK,DGOLD,DGNEW,DGPCE,DGNAME
+3 ;
+4 ;Abort Flag: 1=Abort Setup, 0=Continue Setup
SET DGABRT=0
+5 FOR DGX="BUG","CHK","PORT","870","FIN"
DO @DGX
if DGABRT
QUIT
+6 if DGABRT
DO ABRT
+7 ;
+8 QUIT
+9 ;
BUG ; Before this patch, a category II flag could be inactivated without
+1 ; inactivating patient flag assignments for the inactive category II flag.
+2 ; That bug is fixed and this code cleans up the patient flag assignments.
+3 ;
+4 DO BMES^XPDUTL("Inactivate all active patient record flag assignment records in the")
+5 DO MES^XPDUTL("PRF ASSIGNMENT (#26.13) file when records are associated with an")
+6 DO MES^XPDUTL("inactive category II patient flag.")
+7 ;
+8 ; Loop through the 0 records in DGPF(26.11
+9 ; Because of previous bug, index "ASTAT" is not correct.
+10 ; Inactive entries may appear as active in "ASTAT" index.
+11 ;
+12 NEW FLG,FLGNM,MSG,X
+13 SET FLG=0
+14 FOR
SET FLG=$ORDER(^DGPF(26.11,FLG))
if 'FLG
QUIT
Begin DoDot:1
+15 ;record doesn't exist
SET X=$GET(^DGPF(26.11,FLG,0))
IF '$LENGTH(X)
QUIT
+16 ;record is active
IF $PIECE(X,"^",2)
QUIT
+17 ;
+18 SET FLGNM=$PIECE(X,"^",1)
+19 SET MSG="Second inactivation, see patch DG*5.3*994"
+20 ;inactivate a second time for audit purposes
DO DEACT^DGPFXCRN(FLG,FLGNM,MSG)
+21 ;correct index for this entry
SET DA=FLG
SET DIK="^DGPF(26.11,"
DO IX^DIK
+22 ;
+23 ; Patient flag assignments are not inactivated as part of set logic because patient flag
+24 ; status isn't changing. Flag status was set to inactive and code is re-setting to inactive.
+25 ; Call DGPFDD to inactivate patient flag assignments.
+26 DO INACT^DGPFDD(FLG,0,26.11,DUZ)
End DoDot:1
+27 ;
+28 DO MES^XPDUTL("Patient Record Flag entries cleaned up.")
+29 QUIT
+30 ;
CHK ; Check for existing logical link
+1 NEW X,Y,Z,J
+2 SET DGLNK="VACRNR"
+3 SET X=$$FIND1^DIC(870,"","MX",DGLNK)
IF X>0
Begin DoDot:1
+4 DO BMES^XPDUTL("A Logical Link for "_DGLNK_" already exists and will be overwritten.")
End DoDot:1
+5 ;
+6 SET DGPCE=".01,.02,.08,4.5,2,3,21,200.021,200.05,200.08,400.02,400.03,400.04,400.07"
+7 FOR J=1:1:14
SET $PIECE(DGOLD,",",J)=$$GET1^DIQ(870,X,$PIECE(DGPCE,",",J))
+8 ;
+9 QUIT
+10 ;
PORT ; KIDS has prompted user for port number, set port variable DGPORT
+1 SET Y=$GET(XPDQUES("POSPORT"))
+2 IF (Y="")!(Y="^")
SET DGABRT=1
QUIT
+3 ;
+4 IF Y'?1N.N
SET DGABRT=1
QUIT
+5 SET DGPORT=$GET(Y)
+6 QUIT
+7 ;
870 ; Create HL7 Logical Link
+1 NEW ERR,FDA,X,J
+2 ;
+3 ; Set up the logical link
+4 KILL FDA
+5 ;Node
SET FDA(1,870,"?+1,",.01)=DGLNK
+6 ;Institution
if $PIECE($GET(DGOLD),",",2)'="CERNER"
SET FDA(1,870,"?+1,",.02)="CERNER"
+7 ;DNS Domain
SET FDA(1,870,"?+1,",.08)="hc-vdif-ent.domain.ext"
+8 ;Autostart
SET FDA(1,870,"?+1,",4.5)=1
+9 ;LLP Type
SET FDA(1,870,"?+1,",2)="TCP"
+10 ;Device Type
SET FDA(1,870,"?+1,",3)="NC"
+11 ;Queue Size
SET FDA(1,870,"?+1,",21)=10
+12 ;Exceed Re-transmit Action
SET FDA(1,870,"?+1,",200.021)="R"
+13 ;ACK timeout
SET FDA(1,870,"?+1,",200.05)=20
+14 ;Protocol ID Version
SET FDA(1,870,"?+1,",200.08)=2.3
+15 ;TCP/IP Port
SET FDA(1,870,"?+1,",400.02)=DGPORT
+16 ;TCP/IP Service Type
SET FDA(1,870,"?+1,",400.03)="C"
+17 ;Persistent
SET FDA(1,870,"?+1,",400.04)="N"
+18 ;Say HELO
SET FDA(1,870,"?+1,",400.07)="Y"
+19 ;
+20 DO UPDATE^DIE("E","FDA(1)","","ERR")
+21 IF $DATA(ERR)
Begin DoDot:1
+22 DO BMES^XPDUTL("Unable to file a logical Link for "_DGLNK_".")
+23 SET DGABRT=1
End DoDot:1
QUIT
+24 ;
+25 ; If there were previous values for the logical link, document what was changed.
+26 ;Quit if DGOLD does not have a value
IF '$LENGTH($GET(DGOLD))
QUIT
+27 ;
+28 SET DGNAME="Node,Institution,DNS Domain,Autostart,LLP Type,Device Type,Queue Size,"
+29 SET DGNAME=DGNAME_"Exceed Re-transmit Action,ACK timeout,Protocol ID Version,"
+30 SET DGNAME=DGNAME_"TCP/IP Port,TCP/IP Service Type,Persistent,Say HELO"
+31 SET DGNEW="VACRNR,CERNER,vaauscluhshhl7rtr201.aac.domain.ext,1,TCP,NC,10,R,20,2.3,"
+32 SET DGNEW=DGNEW_DGPORT_",C,N,Y"
+33 ;
+34 SET X="Summary of changes to logical link "_DGLNK
DO BMES^XPDUTL(X)
+35 FOR J=1:1:14
IF '($PIECE(DGOLD,",",J)=$PIECE(DGNEW,",",J))
Begin DoDot:1
+36 SET X=" Value changed for field: "_$PIECE(DGNAME,",",J)
DO MES^XPDUTL(X)
+37 SET X=" OLD: "_$PIECE(DGOLD,",",J)
DO MES^XPDUTL(X)
+38 SET X=" NEW: "_$PIECE(DGNEW,",",J)
DO MES^XPDUTL(X)
End DoDot:1
+39 QUIT
+40 ;
FIN ;
+1 DO BMES^XPDUTL("Logical Link Setup Complete")
+2 QUIT
+3 ;
ABRT ;
+1 DO BMES^XPDUTL("Logical Link Setup Aborted")
+2 QUIT
+3 ;
