Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGY994PO

DGY994PO.m

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