- SRHLPOST ;B'HAM ISC/DLR - POST INIT FOR HL7 SURGERY INTERFACE ; [ 06/11/98 6:06 AM ]
- ;;3.0; Surgery ;**41**;24 Jun 93
- APP ;Create HL7 application in file 771
- N SRAPP,SRIEN,SRMG,SRX,SRZ K DIC S SRMG="",X="SRHL DISCREPANCY",DIC=3.8,DIC(0)="" D ^DIC K DIC I +Y>0 S SRMG=+Y
- S SRAPP="SR SURGERY" I $O(^HL(771,"B",SRAPP,0)) G AAIS
- D MES K DD,DO S DIC="^HL(771,",X=SRAPP,DIC(0)="L",DIC("DR")="2////i;3//// ;7////1" S:SRMG DIC("DR")=DIC("DR")_";4////"_SRMG D FILE^DICN I Y=-1 G AAIS
- MSG K DD,DIC,DO S SRIEN=+Y F SRZ="QRY","ZIU","ZSQ","ORU" S X=SRZ,DIC(0)="",DIC=771.2 D ^DIC K DIC I +Y>0 S SRX=+Y D
- .S X=SRX,DA(1)=SRIEN,DIC="^HL(771,"_DA(1)_",""MSG"",",DIC("P")=$P(^DD(771,6,0),"^",2),DIC(0)="L",DIC("DR")="1///^S X=""SRHLV""_SRZ" D FILE^DICN K DA,DD,DIC,DO,DR
- F SRZ="MSH","QRD","QRF","OBX","OBR" S X=SRZ,DIC(0)="",DIC=771.3 D ^DIC K DIC I +Y>0 S SRX=+Y D
- .D @SRZ
- .S X=SRX,DA(1)=SRIEN,DIC="^HL(771,"_DA(1)_",""SEG"",",DIC("P")=$P(^DD(771,5,0),"^",2),DIC(0)="L" D FILE^DICN K DA,DD,DIC,DO,DR
- AAIS S SRAPP="SR AAIS" I $O(^HL(771,"B",SRAPP,0)) G NON
- D MES K DD,DO S DIC="^HL(771,",X=SRAPP,DIC(0)="L",DIC("DR")="2////i;3//// ;7////1" S:SRMG DIC("DR")=DIC("DR")_";4////"_SRMG D FILE^DICN K DA,DD,DIC,DO,DR
- NON I $O(^HL(770,"B",SRAPP,0)) G END
- D BMES^XPDUTL("Adding the Surgery NON-DHCP HL7 Application SR AAIS.")
- N SITE S SITE=$$SITE^SROVAR
- K DD,DO S DIC="^HL(770,",X=SRAPP,DIC(0)="L",DIC("DR")="2////"_$P(SITE,"^",3)_";3////"_$P(SITE,"^",3)_";4///^S X=245;5///^S X=3;7///^S X=2.1;8///^S X=""SR SURGERY"";14///^S X=""DEBUG""" D FILE^DICN K DA,DD,DIC,DO,DR
- END D TCP("AAIS","SURGERY")
- D BMES^XPDUTL("SURGERY HL7 SETUP IS COMPLETE.")
- Q
- MES D BMES^XPDUTL("Adding the HL7 Application "_SRAPP_" to file 771")
- Q
- TCP(SRI,PRIMARY) ;
- I '$$PATCH^XPDUTL("HL*1.6*19") D BMES^XPDUTL("Patch HL*1.6*19 must be installed before setting up a TCP/IP link!") Q
- Q:SRI=""!PRIMARY=""
- N SRHLX,SRCLNT,X
- D BMES^XPDUTL("Updating HL LOGICAL LINK file (#870).")
- S (DIC,DIE)="^HLCS(870,",DIC(0)="L",DLAYGO=870,SRX="SR"_SRI_"T"_PRIMARY_"-TCP",X="SR "_SRI D ^DIC D:$P(Y,U,3) BMES^XPDUTL(" Adding SR "_SRI) D
- . I +Y<0 D BMES^XPDUTL("Failure SR "_SRI_" was not created in file #870.") Q
- . I $P(Y,U,3) S DA=+Y S DR="2///"_SRX D ^DIE K DIC,DA,DIE,DR,DLAYGO
- S (DIC,DIE)="^HLCS(870,",DIC(0)="L",DLAYGO=870,SRX="SR"_PRIMARY_"-TCP-RECV",X="SR "_PRIMARY D ^DIC D:$P(Y,U,3) BMES^XPDUTL(" Adding SR "_PRIMARY) D
- . I +Y<0 D BMES^XPDUTL("Failure SR "_PRIMARY_" was not created in file #870.") Q
- . I $P(Y,U,3) S DA=+Y S DR="2///"_SRX D ^DIE K DIC,DA,DIE,DR,DLAYGO
- D LL
- Q
- LL D BMES^XPDUTL("Updating the PROTOCOL file (#101) with the new TCP/IP connect")
- S SRCLNT="SR Receiver of Appointment Cancellation" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Appointment Deletion" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Appointment Modification" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Appointment Rescheduling" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Master File Notification" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of New Appointment Booking" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Observation Unsolicited" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Scheduling Query" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Staff Master File Notification" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- S SRCLNT="SR Receiver of Unsolicited Requested Observation" S X=SRCLNT D SETPRO(X,"770.7///SR "_SRI)
- Q
- SETPRO(X,FLDS) ;
- K DR,DA,DIC,DIE,D0 S DIC="^ORD(101,",DIC(0)="M" D ^DIC I +Y>0 S DA=+Y,DR=FLDS,DIE=DIC D ^DIE K DIC,DIE,D0,DR,DA
- Q
- MSH S DIC("DR")="2///^S X=""1,2,3,4,5,6,7,8,9,10,11,12"""
- Q
- QRD S DIC("DR")="2///^S X=""1,2,3,4,7,8,9,10"""
- Q
- QRF S DIC("DR")="2///^S X=""1,2,3"""
- Q
- OBX S DIC("DR")="2///^S X=""1,2,3,5,6,11,14,16"""
- Q
- OBR S DIC("DR")="2///^S X="" """
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSRHLPOST 3999 printed Feb 19, 2025@00:05:48 Page 2
- SRHLPOST ;B'HAM ISC/DLR - POST INIT FOR HL7 SURGERY INTERFACE ; [ 06/11/98 6:06 AM ]
- +1 ;;3.0; Surgery ;**41**;24 Jun 93
- APP ;Create HL7 application in file 771
- +1 NEW SRAPP,SRIEN,SRMG,SRX,SRZ
- KILL DIC
- SET SRMG=""
- SET X="SRHL DISCREPANCY"
- SET DIC=3.8
- SET DIC(0)=""
- DO ^DIC
- KILL DIC
- IF +Y>0
- SET SRMG=+Y
- +2 SET SRAPP="SR SURGERY"
- IF $ORDER(^HL(771,"B",SRAPP,0))
- GOTO AAIS
- +3 DO MES
- KILL DD,DO
- SET DIC="^HL(771,"
- SET X=SRAPP
- SET DIC(0)="L"
- SET DIC("DR")="2////i;3//// ;7////1"
- if SRMG
- SET DIC("DR")=DIC("DR")_";4////"_SRMG
- DO FILE^DICN
- IF Y=-1
- GOTO AAIS
- MSG KILL DD,DIC,DO
- SET SRIEN=+Y
- FOR SRZ="QRY","ZIU","ZSQ","ORU"
- SET X=SRZ
- SET DIC(0)=""
- SET DIC=771.2
- DO ^DIC
- KILL DIC
- IF +Y>0
- SET SRX=+Y
- Begin DoDot:1
- +1 SET X=SRX
- SET DA(1)=SRIEN
- SET DIC="^HL(771,"_DA(1)_",""MSG"","
- SET DIC("P")=$PIECE(^DD(771,6,0),"^",2)
- SET DIC(0)="L"
- SET DIC("DR")="1///^S X=""SRHLV""_SRZ"
- DO FILE^DICN
- KILL DA,DD,DIC,DO,DR
- End DoDot:1
- +2 FOR SRZ="MSH","QRD","QRF","OBX","OBR"
- SET X=SRZ
- SET DIC(0)=""
- SET DIC=771.3
- DO ^DIC
- KILL DIC
- IF +Y>0
- SET SRX=+Y
- Begin DoDot:1
- +3 DO @SRZ
- +4 SET X=SRX
- SET DA(1)=SRIEN
- SET DIC="^HL(771,"_DA(1)_",""SEG"","
- SET DIC("P")=$PIECE(^DD(771,5,0),"^",2)
- SET DIC(0)="L"
- DO FILE^DICN
- KILL DA,DD,DIC,DO,DR
- End DoDot:1
- AAIS SET SRAPP="SR AAIS"
- IF $ORDER(^HL(771,"B",SRAPP,0))
- GOTO NON
- +1 DO MES
- KILL DD,DO
- SET DIC="^HL(771,"
- SET X=SRAPP
- SET DIC(0)="L"
- SET DIC("DR")="2////i;3//// ;7////1"
- if SRMG
- SET DIC("DR")=DIC("DR")_";4////"_SRMG
- DO FILE^DICN
- KILL DA,DD,DIC,DO,DR
- NON IF $ORDER(^HL(770,"B",SRAPP,0))
- GOTO END
- +1 DO BMES^XPDUTL("Adding the Surgery NON-DHCP HL7 Application SR AAIS.")
- +2 NEW SITE
- SET SITE=$$SITE^SROVAR
- +3 KILL DD,DO
- SET DIC="^HL(770,"
- SET X=SRAPP
- SET DIC(0)="L"
- SET DIC("DR")="2////"_$PIECE(SITE,"^",3)_";3////"_$PIECE(SITE,"^",3)_";4///^S X=245;5///^S X=3;7///^S X=2.1;8///^S X=""SR SURGERY"";14///^S X=""DEBUG"""
- DO FILE^DICN
- KILL DA,DD,DIC,DO,DR
- END DO TCP("AAIS","SURGERY")
- +1 DO BMES^XPDUTL("SURGERY HL7 SETUP IS COMPLETE.")
- +2 QUIT
- MES DO BMES^XPDUTL("Adding the HL7 Application "_SRAPP_" to file 771")
- +1 QUIT
- TCP(SRI,PRIMARY) ;
- +1 IF '$$PATCH^XPDUTL("HL*1.6*19")
- DO BMES^XPDUTL("Patch HL*1.6*19 must be installed before setting up a TCP/IP link!")
- QUIT
- +2 if SRI=""!PRIMARY=""
- QUIT
- +3 NEW SRHLX,SRCLNT,X
- +4 DO BMES^XPDUTL("Updating HL LOGICAL LINK file (#870).")
- +5 SET (DIC,DIE)="^HLCS(870,"
- SET DIC(0)="L"
- SET DLAYGO=870
- SET SRX="SR"_SRI_"T"_PRIMARY_"-TCP"
- SET X="SR "_SRI
- DO ^DIC
- if $PIECE(Y,U,3)
- DO BMES^XPDUTL(" Adding SR "_SRI)
- Begin DoDot:1
- +6 IF +Y<0
- DO BMES^XPDUTL("Failure SR "_SRI_" was not created in file #870.")
- QUIT
- +7 IF $PIECE(Y,U,3)
- SET DA=+Y
- SET DR="2///"_SRX
- DO ^DIE
- KILL DIC,DA,DIE,DR,DLAYGO
- End DoDot:1
- +8 SET (DIC,DIE)="^HLCS(870,"
- SET DIC(0)="L"
- SET DLAYGO=870
- SET SRX="SR"_PRIMARY_"-TCP-RECV"
- SET X="SR "_PRIMARY
- DO ^DIC
- if $PIECE(Y,U,3)
- DO BMES^XPDUTL(" Adding SR "_PRIMARY)
- Begin DoDot:1
- +9 IF +Y<0
- DO BMES^XPDUTL("Failure SR "_PRIMARY_" was not created in file #870.")
- QUIT
- +10 IF $PIECE(Y,U,3)
- SET DA=+Y
- SET DR="2///"_SRX
- DO ^DIE
- KILL DIC,DA,DIE,DR,DLAYGO
- End DoDot:1
- +11 DO LL
- +12 QUIT
- LL DO BMES^XPDUTL("Updating the PROTOCOL file (#101) with the new TCP/IP connect")
- +1 SET SRCLNT="SR Receiver of Appointment Cancellation"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +2 SET SRCLNT="SR Receiver of Appointment Deletion"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +3 SET SRCLNT="SR Receiver of Appointment Modification"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +4 SET SRCLNT="SR Receiver of Appointment Rescheduling"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +5 SET SRCLNT="SR Receiver of Master File Notification"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +6 SET SRCLNT="SR Receiver of New Appointment Booking"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +7 SET SRCLNT="SR Receiver of Observation Unsolicited"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +8 SET SRCLNT="SR Receiver of Scheduling Query"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +9 SET SRCLNT="SR Receiver of Staff Master File Notification"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +10 SET SRCLNT="SR Receiver of Unsolicited Requested Observation"
- SET X=SRCLNT
- DO SETPRO(X,"770.7///SR "_SRI)
- +11 QUIT
- SETPRO(X,FLDS) ;
- +1 KILL DR,DA,DIC,DIE,D0
- SET DIC="^ORD(101,"
- SET DIC(0)="M"
- DO ^DIC
- IF +Y>0
- SET DA=+Y
- SET DR=FLDS
- SET DIE=DIC
- DO ^DIE
- KILL DIC,DIE,D0,DR,DA
- +2 QUIT
- MSH SET DIC("DR")="2///^S X=""1,2,3,4,5,6,7,8,9,10,11,12"""
- +1 QUIT
- QRD SET DIC("DR")="2///^S X=""1,2,3,4,7,8,9,10"""
- +1 QUIT
- QRF SET DIC("DR")="2///^S X=""1,2,3"""
- +1 QUIT
- OBX SET DIC("DR")="2///^S X=""1,2,3,5,6,11,14,16"""
- +1 QUIT
- OBR SET DIC("DR")="2///^S X="" """
- +1 QUIT