- 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 Feb 19, 2025@00:26:08 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 ;