Released EAS*1*71 SEQ #71 Extracted from mail message **KIDS**:EAS*1.0*71^ **INSTALL NAME** EAS*1.0*71 "BLD",7093,0) EAS*1.0*71^ENROLLMENT APPLICATION SYSTEM^0^3071127^y "BLD",7093,4,0) ^9.64PA^^ "BLD",7093,6) 10^ "BLD",7093,6.3) 18 "BLD",7093,"ABPKG") n "BLD",7093,"INIT") EN^EAS1071P "BLD",7093,"KRN",0) ^9.67PA^8989.52^19 "BLD",7093,"KRN",.4,0) .4 "BLD",7093,"KRN",.401,0) .401 "BLD",7093,"KRN",.402,0) .402 "BLD",7093,"KRN",.403,0) .403 "BLD",7093,"KRN",.5,0) .5 "BLD",7093,"KRN",.84,0) .84 "BLD",7093,"KRN",3.6,0) 3.6 "BLD",7093,"KRN",3.8,0) 3.8 "BLD",7093,"KRN",9.2,0) 9.2 "BLD",7093,"KRN",9.8,0) 9.8 "BLD",7093,"KRN",9.8,"NM",0) ^9.68A^10^9 "BLD",7093,"KRN",9.8,"NM",1,0) EAS1071P^^0^B43511372 "BLD",7093,"KRN",9.8,"NM",2,0) EAS1071Q^^0^B23165038 "BLD",7093,"KRN",9.8,"NM",4,0) EASPREC4^^0^B25401092 "BLD",7093,"KRN",9.8,"NM",5,0) EASCM^^0^B80510854 "BLD",7093,"KRN",9.8,"NM",6,0) EASEGT2^^0^B33652656 "BLD",7093,"KRN",9.8,"NM",7,0) EASPREC3^^0^B11323531 "BLD",7093,"KRN",9.8,"NM",8,0) EAS1071A^^0^B72340159 "BLD",7093,"KRN",9.8,"NM",9,0) EAS1071B^^0^B26013480 "BLD",7093,"KRN",9.8,"NM",10,0) EAS1071C^^0^B6862758 "BLD",7093,"KRN",9.8,"NM","B","EAS1071A",8) "BLD",7093,"KRN",9.8,"NM","B","EAS1071B",9) "BLD",7093,"KRN",9.8,"NM","B","EAS1071C",10) "BLD",7093,"KRN",9.8,"NM","B","EAS1071P",1) "BLD",7093,"KRN",9.8,"NM","B","EAS1071Q",2) "BLD",7093,"KRN",9.8,"NM","B","EASCM",5) "BLD",7093,"KRN",9.8,"NM","B","EASEGT2",6) "BLD",7093,"KRN",9.8,"NM","B","EASPREC3",7) "BLD",7093,"KRN",9.8,"NM","B","EASPREC4",4) "BLD",7093,"KRN",19,0) 19 "BLD",7093,"KRN",19,"NM",0) ^9.68A^^ "BLD",7093,"KRN",19.1,0) 19.1 "BLD",7093,"KRN",101,0) 101 "BLD",7093,"KRN",409.61,0) 409.61 "BLD",7093,"KRN",771,0) 771 "BLD",7093,"KRN",870,0) 870 "BLD",7093,"KRN",8989.51,0) 8989.51 "BLD",7093,"KRN",8989.52,0) 8989.52 "BLD",7093,"KRN",8994,0) 8994 "BLD",7093,"KRN",8994,"NM",0) ^9.68A^1^1 "BLD",7093,"KRN",8994,"NM",1,0) EAS ESR MESSAGING^^0 "BLD",7093,"KRN",8994,"NM","B","EAS ESR MESSAGING",1) "BLD",7093,"KRN","B",.4,.4) "BLD",7093,"KRN","B",.401,.401) "BLD",7093,"KRN","B",.402,.402) "BLD",7093,"KRN","B",.403,.403) "BLD",7093,"KRN","B",.5,.5) "BLD",7093,"KRN","B",.84,.84) "BLD",7093,"KRN","B",3.6,3.6) "BLD",7093,"KRN","B",3.8,3.8) "BLD",7093,"KRN","B",9.2,9.2) "BLD",7093,"KRN","B",9.8,9.8) "BLD",7093,"KRN","B",19,19) "BLD",7093,"KRN","B",19.1,19.1) "BLD",7093,"KRN","B",101,101) "BLD",7093,"KRN","B",409.61,409.61) "BLD",7093,"KRN","B",771,771) "BLD",7093,"KRN","B",870,870) "BLD",7093,"KRN","B",8989.51,8989.51) "BLD",7093,"KRN","B",8989.52,8989.52) "BLD",7093,"KRN","B",8994,8994) "BLD",7093,"QUES",0) ^9.62^^ "BLD",7093,"REQB",0) ^9.611^^ "INIT") EN^EAS1071P "KRN",8994,2050,-1) 0^1 "KRN",8994,2050,0) EAS ESR MESSAGING^TAG^EAS1071A^2^^^^^1 "KRN",8994,2050,1,0) ^8994.01^1^1^3061130^^^^ "KRN",8994,2050,1,1,0) This is a stub RPC to trigger dual messaging changes on Vista Sites "KRN",8994,2050,2,0) ^8994.02A^1^1 "KRN",8994,2050,2,1,0) MODE^1^16^1^1 "KRN",8994,2050,2,"B","MODE",1) "KRN",8994,2050,2,"PARAMSEQ",1,1) "KRN",8994,2050,3,0) ^8994.03^2^2^3061130^^ "KRN",8994,2050,3,1,0) The RPC will return error if the Vista process is unable to perform the "KRN",8994,2050,3,2,0) required messaging changes for Vista/ESR or Vista/HEC. "MBREQ") 0 "ORD",16,8994) 8994;16;1;;;;;;;RPCDEL^XPDIA1 "ORD",16,8994,0) REMOTE PROCEDURE "PKG",187,-1) 1^1 "PKG",187,0) ENROLLMENT APPLICATION SYSTEM^EAS^ENROLLMENT "PKG",187,20,0) ^9.402P^1^1 "PKG",187,20,1,0) 2^^EASXDR "PKG",187,20,1,1) "PKG",187,20,"B",2,1) "PKG",187,22,0) ^9.49I^1^1 "PKG",187,22,1,0) 1.0^3010315^3010321^66481 "PKG",187,22,1,"PAH",1,0) 71^3071127^123456988 "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 9 "RTN","EAS1071A") 0^8^B72340159^n/a "RTN","EAS1071A",1,0) EAS1071A ;ALB/PJH - ESR and HEC Messaging ; 11/27/07 3:01pm "RTN","EAS1071A",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EAS1071A",3,0) ; "RTN","EAS1071A",4,0) ;PROTOCOL FILE access through DBIA 3173 "RTN","EAS1071A",5,0) ; "RTN","EAS1071A",6,0) TAG(RETURN,MODE) ; Called from EAS ESR MESSAGING RPC (triggered from HEC) "RTN","EAS1071A",7,0) N STOP "RTN","EAS1071A",8,0) S STOP=0 "RTN","EAS1071A",9,0) ;Enable ESR "RTN","EAS1071A",10,0) I MODE=1 D EN1(.RETURN) D:STOP RESET(.RETURN) Q "RTN","EAS1071A",11,0) ;Set ESR as system of record "RTN","EAS1071A",12,0) I MODE=2 D QRY(.RETURN,"ESR") D:STOP QRY(.RETURN,"HEC") Q "RTN","EAS1071A",13,0) ;Remove HEC "RTN","EAS1071A",14,0) I MODE=3 D EN^EAS1071B(.RETURN) D:STOP RESET^EAS1071B(.RETURN) Q "RTN","EAS1071A",15,0) ;Remove ESR "RTN","EAS1071A",16,0) I MODE=4 D RESET(.RETURN) D:STOP EN1(.RETURN) Q "RTN","EAS1071A",17,0) ;Set HEC as system of record "RTN","EAS1071A",18,0) I MODE=5 D QRY(.RETURN,"HEC") D:STOP QRY(.RETURN,"ESR") Q "RTN","EAS1071A",19,0) ;Enable HEC "RTN","EAS1071A",20,0) I MODE=6 D RESET^EAS1071B(.RETURN) Q "RTN","EAS1071A",21,0) ; "RTN","EAS1071A",22,0) S RETURN="-1^RPC Called with invalid MODE parameter" "RTN","EAS1071A",23,0) Q "RTN","EAS1071A",24,0) ; "RTN","EAS1071A",25,0) EN1(ARR) ;Enable ESR messaging "RTN","EAS1071A",26,0) ; "RTN","EAS1071A",27,0) N ADDR,PORT,STATION,TCPDATA,SLLN,VER,DA,FILE,RET,ERROR "RTN","EAS1071A",28,0) ; "RTN","EAS1071A",29,0) S:MODE=1 ARR="ESR messaging NOT enabled" "RTN","EAS1071A",30,0) ; "RTN","EAS1071A",31,0) ; Get site's Station # "RTN","EAS1071A",32,0) S STATION=$P($$SITE^VASITE,"^",3) "RTN","EAS1071A",33,0) ; "RTN","EAS1071A",34,0) ;Activate EAS ESR event driver server protocols "RTN","EAS1071A",35,0) D PROTOCOL Q:STOP "RTN","EAS1071A",36,0) ;Update VAMC event driver protocols (outgoing) "RTN","EAS1071A",37,0) D DRIVERS(STATION) Q:STOP "RTN","EAS1071A",38,0) ;Set production IP address and port on Logical Links "RTN","EAS1071A",39,0) D SETLL16 Q:STOP "RTN","EAS1071A",40,0) ; "RTN","EAS1071A",41,0) S:MODE=1 ARR="ESR messaging enabled" "RTN","EAS1071A",42,0) ; "RTN","EAS1071A",43,0) Q "RTN","EAS1071A",44,0) ; "RTN","EAS1071A",45,0) SETLL16 ;Update Sending Logical Link "RTN","EAS1071A",46,0) ; "RTN","EAS1071A",47,0) N ADDR,PORT,SHUTDOWN,SLLN,RET "RTN","EAS1071A",48,0) ; "RTN","EAS1071A",49,0) ;Production Install "RTN","EAS1071A",50,0) I $$PROD^XUPROD D Q:STOP "RTN","EAS1071A",51,0) .S PORT=8090 ;Vitria production port# "RTN","EAS1071A",52,0) .S ADDR=$$IPLIVE ;ESR production (from dental package) "RTN","EAS1071A",53,0) .S SHUTDOWN="" ;Shutdown LLP set to No "RTN","EAS1071A",54,0) .;Abort if no IP address found for production account "RTN","EAS1071A",55,0) .I ADDR="" D ABORT1 Q "RTN","EAS1071A",56,0) ;Test/development account values to null "RTN","EAS1071A",57,0) E S PORT="",ADDR="00.0.000.00",SHUTDOWN=1 "RTN","EAS1071A",58,0) ;Update value in logical link file "RTN","EAS1071A",59,0) S SLLN="LLESROUT",RET=$$LL16(SLLN,ADDR,PORT,SHUTDOWN) "RTN","EAS1071A",60,0) I +RET<0 D ABORT2(RET,"ESR Send Link:"_SLLN) "RTN","EAS1071A",61,0) Q "RTN","EAS1071A",62,0) ; "RTN","EAS1071A",63,0) ; "RTN","EAS1071A",64,0) PROTOCOL ;Remove Disable Text from EAS ESR server protocols "RTN","EAS1071A",65,0) ; "RTN","EAS1071A",66,0) N RESULT,SIEN,V,N,N1,LNCNT,LINE,PROTRET,NAM "RTN","EAS1071A",67,0) S NAM="EAS ESR" "RTN","EAS1071A",68,0) F S NAM=$O(^ORD(101,"B",NAM)) Q:NAM'["EAS ESR" D Q:STOP "RTN","EAS1071A",69,0) . Q:NAM'["SERVER" Q:NAM["QRY-Z10" Q:NAM["QRY-Z11" "RTN","EAS1071A",70,0) . S RESULT=$$EDP(NAM,"") "RTN","EAS1071A",71,0) . I +RESULT<0 D ABORT2(RESULT,"Event Driver:"_NAM) "RTN","EAS1071A",72,0) ; "RTN","EAS1071A",73,0) Q "RTN","EAS1071A",74,0) ; "RTN","EAS1071A",75,0) DRIVERS(STATION) ;Add EAS ESR client to VAMC event driver "RTN","EAS1071A",76,0) ; "RTN","EAS1071A",77,0) N ERROR,FILE,IEN101,LINE,LNCNT,RETURN,SIEN101,SNAM "RTN","EAS1071A",78,0) S LNCNT=1 "RTN","EAS1071A",79,0) F S LINE=$T(PROTDAT+LNCNT) Q:$P(LINE,";",3)="END" D Q:STOP "RTN","EAS1071A",80,0) .S NAM="VAMC "_STATION_" "_$P(LINE,";",3)_" SERVER" "RTN","EAS1071A",81,0) .S IEN101=$O(^ORD(101,"B",NAM,0)) "RTN","EAS1071A",82,0) .I +IEN101=0 D Q "RTN","EAS1071A",83,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071A",84,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071A",85,0) ..D ABORT2(RETURN,"Event Driver:"_NAM) "RTN","EAS1071A",86,0) .; "RTN","EAS1071A",87,0) .;Client Protocol "RTN","EAS1071A",88,0) .S SNAM="EAS ESR "_STATION_" "_$P(LINE,";",3)_" CLIENT" "RTN","EAS1071A",89,0) .S SIEN101=$O(^ORD(101,"B",SNAM,0)) "RTN","EAS1071A",90,0) .I +SIEN101=0 D Q "RTN","EAS1071A",91,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071A",92,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071A",93,0) ..D ABORT2(RETURN,"Subscriber:"_SNAM) "RTN","EAS1071A",94,0) .;Skip if already present "RTN","EAS1071A",95,0) .I $D(^ORD(101,IEN101,775,"B",SIEN101)) D Q "RTN","EAS1071A",96,0) ..D WARN(NAM,SNAM) "RTN","EAS1071A",97,0) ..S LNCNT=LNCNT+1 "RTN","EAS1071A",98,0) .;Add subscriber to event driver "RTN","EAS1071A",99,0) .S RETURN=$$SUBSCR(IEN101,SIEN101) "RTN","EAS1071A",100,0) .I +RETURN<0 D ABORT2(RETURN,"driver with Subscriber:"_SNAM) Q "RTN","EAS1071A",101,0) .S LNCNT=LNCNT+1 "RTN","EAS1071A",102,0) ; "RTN","EAS1071A",103,0) Q "RTN","EAS1071A",104,0) ; "RTN","EAS1071A",105,0) WARN(EDP,SP) ;Display Warning Message "RTN","EAS1071A",106,0) ; "RTN","EAS1071A",107,0) N ARR "RTN","EAS1071A",108,0) ; "RTN","EAS1071A",109,0) S ARR(1)="====================================================" "RTN","EAS1071A",110,0) S ARR(2)="= WARNING =" "RTN","EAS1071A",111,0) S ARR(3)="====================================================" "RTN","EAS1071A",112,0) S ARR(4)="When updating "_EDP "RTN","EAS1071A",113,0) S ARR(5)="====================================================" "RTN","EAS1071A",114,0) S ARR(5)="**"_SP_" is already defined**" "RTN","EAS1071A",115,0) ; "RTN","EAS1071A",116,0) Q "RTN","EAS1071A",117,0) ; "RTN","EAS1071A",118,0) ABORT1 ;Warning and mail message in case of no IP address "RTN","EAS1071A",119,0) ; "RTN","EAS1071A",120,0) S STOP=1 "RTN","EAS1071A",121,0) S ARR(1)="====================================================" "RTN","EAS1071A",122,0) S ARR(2)="= ABORTED =" "RTN","EAS1071A",123,0) S ARR(3)="====================================================" "RTN","EAS1071A",124,0) S ARR(4)="No IP address for VIE was found on the system" "RTN","EAS1071A",125,0) S ARR(5)="The IP address must be entered on the LLESROUT" "RTN","EAS1071A",126,0) S ARR(6)="logical link (file #870) before ESR transmissions" "RTN","EAS1071A",127,0) S ARR(7)="can begin" "RTN","EAS1071A",128,0) Q "RTN","EAS1071A",129,0) ; "RTN","EAS1071A",130,0) ABORT2(ERRMSG,SUBJ) ;Display Install Error message and set STOP "RTN","EAS1071A",131,0) ; "RTN","EAS1071A",132,0) S STOP=1 "RTN","EAS1071A",133,0) S ARR(1)="====================================================" "RTN","EAS1071A",134,0) S ARR(2)="= ABORTED =" "RTN","EAS1071A",135,0) S ARR(3)="====================================================" "RTN","EAS1071A",136,0) S ARR(4)="When updating "_SUBJ "RTN","EAS1071A",137,0) S ARR(5)="====================================================" "RTN","EAS1071A",138,0) S ARR(5)="**ERROR MSG: "_$P(ERRMSG,"^",2) "RTN","EAS1071A",139,0) Q "RTN","EAS1071A",140,0) ; "RTN","EAS1071A",141,0) LL16(LLNAME,TCPADDR,TCPPORT,SHUTDOWN) ;Update Logical Link Port and Address "RTN","EAS1071A",142,0) ; "RTN","EAS1071A",143,0) N FILE,DATA,RETURN,DEFINED,ERROR,DA,DGENDA "RTN","EAS1071A",144,0) S FILE=870 "RTN","EAS1071A",145,0) S IEN870=$O(^HLCS(870,"B",LLNAME,0)) "RTN","EAS1071A",146,0) I 'IEN870 D Q RETURN "RTN","EAS1071A",147,0) . S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071A",148,0) . S RETURN=-1_"^"_ERROR "RTN","EAS1071A",149,0) ; "RTN","EAS1071A",150,0) S DATA(400.01)=TCPADDR ;TCP/IP ADDRESS "RTN","EAS1071A",151,0) S DATA(400.02)=TCPPORT ;TCP/IP PORT "RTN","EAS1071A",152,0) S DATA(4.5)=1 ;AUTOSTART "RTN","EAS1071A",153,0) S DATA(14)=SHUTDOWN ;SHUTDOWN LLP "RTN","EAS1071A",154,0) ; "RTN","EAS1071A",155,0) S RETURN=$$UPD^DGENDBS(FILE,IEN870,.DATA,.ERROR) "RTN","EAS1071A",156,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071A",157,0) ; "RTN","EAS1071A",158,0) Q RETURN "RTN","EAS1071A",159,0) ; "RTN","EAS1071A",160,0) EDP(PNAME,DTXT) ;Remove Disable Text from Event Driver Protocols "RTN","EAS1071A",161,0) ; "RTN","EAS1071A",162,0) N DATA,FILE,DGENDA,RETURN,ERROR,DA "RTN","EAS1071A",163,0) S FILE=101 "RTN","EAS1071A",164,0) ; If already exists then skip "RTN","EAS1071A",165,0) S IEN101=$O(^ORD(101,"B",PNAME,0)) "RTN","EAS1071A",166,0) I 'IEN101 D Q RETURN "RTN","EAS1071A",167,0) . S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071A",168,0) . S RETURN=-1_"^"_ERROR "RTN","EAS1071A",169,0) ; "RTN","EAS1071A",170,0) S DATA(2)=DTXT "RTN","EAS1071A",171,0) S RETURN=$$UPD^DGENDBS(FILE,IEN101,.DATA,.ERROR) "RTN","EAS1071A",172,0) I ERROR'=""!(+RETURN=0) S RETURN=-1_"^"_ERROR "RTN","EAS1071A",173,0) ; "RTN","EAS1071A",174,0) Q RETURN "RTN","EAS1071A",175,0) ; "RTN","EAS1071A",176,0) SUBSCR(IEN101,SIEN101) ;Add client to event driver as a subscriber "RTN","EAS1071A",177,0) ; "RTN","EAS1071A",178,0) N DATA,DGENDA,ERROR,FILE,RETURN "RTN","EAS1071A",179,0) S DGENDA(1)=IEN101 "RTN","EAS1071A",180,0) S FILE=101.0775 "RTN","EAS1071A",181,0) S DATA(.01)=SIEN101 "RTN","EAS1071A",182,0) S RETURN=$$ADD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR) "RTN","EAS1071A",183,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071A",184,0) ; "RTN","EAS1071A",185,0) Q RETURN "RTN","EAS1071A",186,0) ; "RTN","EAS1071A",187,0) IPLIVE() ;Get IP address for production system "RTN","EAS1071A",188,0) ; "RTN","EAS1071A",189,0) ;Search for DENTVHLAAC logical link "RTN","EAS1071A",190,0) S IENS=$$FIND1^DIC(870,"","X","DENTVHLAAC","","","ERR") "RTN","EAS1071A",191,0) ;If not found return null IP address "RTN","EAS1071A",192,0) I 'IENS Q "" "RTN","EAS1071A",193,0) ;Otherwise return TCP/IP ADDRESS "RTN","EAS1071A",194,0) Q $$GET1^DIQ(870,IENS_",",400.01) "RTN","EAS1071A",195,0) ; "RTN","EAS1071A",196,0) RESET(ARR) ;Disable or Remove ESR protocols "RTN","EAS1071A",197,0) N DA,DIK,ERROR,IEN101,LINE,LCT,NAM "RTN","EAS1071A",198,0) N PREFHEC,PREFESR,SIEN101,SNAM,STOP,SITE "RTN","EAS1071A",199,0) ; "RTN","EAS1071A",200,0) I MODE=4 S ARR="ESR messaging NOT disabled" "RTN","EAS1071A",201,0) ; "RTN","EAS1071A",202,0) ; Get site's Station # "RTN","EAS1071A",203,0) S SITE=$P($$SITE^VASITE,"^",3) "RTN","EAS1071A",204,0) S PREFHEC="VAMC "_SITE_" " "RTN","EAS1071A",205,0) S PREFESR="EAS ESR "_SITE_" " "RTN","EAS1071A",206,0) S STOP=0 "RTN","EAS1071A",207,0) ; "RTN","EAS1071A",208,0) I $$SOR^EAS1071C(PREFESR,PREFHEC) D Q "RTN","EAS1071A",209,0) .S ARR="Unable to disable messaging, ESR is SOR" "RTN","EAS1071A",210,0) ; "RTN","EAS1071A",211,0) ;Disable to Vista to ESR servers "RTN","EAS1071A",212,0) S NAM="EAS ESR" "RTN","EAS1071A",213,0) F S NAM=$O(^ORD(101,"B",NAM)) Q:NAM'["EAS ESR" D Q:STOP "RTN","EAS1071A",214,0) .Q:NAM'["SERVER" Q:NAM["QRY-Z10" Q:NAM["QRY-Z11" "RTN","EAS1071A",215,0) .;Insert disable text "RTN","EAS1071A",216,0) .S RESULT=$$EDP(NAM,"ESR-to-Site Messaging Inactive") "RTN","EAS1071A",217,0) .I +RESULT<0 D ABORT2(RESULT,"Event Driver:"_NAM) "RTN","EAS1071A",218,0) ; "RTN","EAS1071A",219,0) ;Remove ESR client subscriber protocols from shared servers "RTN","EAS1071A",220,0) F LCT=1:1 S LINE=$T(PROTDAT+LCT) Q:$P(LINE,";",3)="END" D Q:STOP "RTN","EAS1071A",221,0) .S NAM=PREFESR_$P(LINE,";",3)_" CLIENT" "RTN","EAS1071A",222,0) .S SIEN101=$O(^ORD(101,"B",NAM,0)) "RTN","EAS1071A",223,0) .I +SIEN101=0 D Q "RTN","EAS1071A",224,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071A",225,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071A",226,0) ..D ABORT2(RETURN,"Event Driver:"_NAM) "RTN","EAS1071A",227,0) .;If this is a SUBSCRIBER remove from SERVER "RTN","EAS1071A",228,0) .I $O(^ORD(101,"AB",SIEN101,0)) D REMOVE(SIEN101,NAM) "RTN","EAS1071A",229,0) ; "RTN","EAS1071A",230,0) ; "RTN","EAS1071A",231,0) I MODE=4,'STOP S ARR="ESR messaging disabled" "RTN","EAS1071A",232,0) Q "RTN","EAS1071A",233,0) ; "RTN","EAS1071A",234,0) REMOVE(CLIENT,CNAM) ;Remove clients from server "RTN","EAS1071A",235,0) N DA,DIK,SERV,SNAM,SUB "RTN","EAS1071A",236,0) S SERV=0 "RTN","EAS1071A",237,0) F S SERV=$O(^ORD(101,"AB",CLIENT,SERV)) Q:'SERV D "RTN","EAS1071A",238,0) .S SUB=0,SNAM=$P($G(^ORD(101,SERV,0)),U) "RTN","EAS1071A",239,0) .F S SUB=$O(^ORD(101,"AB",CLIENT,SERV,SUB)) Q:'SUB D "RTN","EAS1071A",240,0) ..S DA(1)=SERV,DA=SUB,DIK="^ORD(101,"_DA(1)_",775," D ^DIK "RTN","EAS1071A",241,0) Q "RTN","EAS1071A",242,0) ; "RTN","EAS1071A",243,0) PROTDAT ; "RTN","EAS1071A",244,0) ;;ORU-Z07 "RTN","EAS1071A",245,0) ;;ORU-Z09 "RTN","EAS1071A",246,0) ;;ORF-Z07 "RTN","EAS1071A",247,0) ;;END "RTN","EAS1071A",248,0) ; "RTN","EAS1071A",249,0) QRY(ARR,SYS) ;Switch system of record (moves QRY-Z10/Z11 Protocols) "RTN","EAS1071A",250,0) ; "RTN","EAS1071A",251,0) N PREFHEC,PREFESR,RESULT,SIEN,SITE,V,N,N1,LNCNT,LINE,PROTRET,NAM "RTN","EAS1071A",252,0) ; Get site's Station # "RTN","EAS1071A",253,0) S SITE=$P($$SITE^VASITE,"^",3) "RTN","EAS1071A",254,0) S PREFHEC="VAMC "_SITE_" " "RTN","EAS1071A",255,0) S PREFESR="EAS ESR "_SITE_" " "RTN","EAS1071A",256,0) S STOP=0,ARR="SOR unchanged" "RTN","EAS1071A",257,0) ; "RTN","EAS1071A",258,0) N ERROR,PREF,RETURN "RTN","EAS1071A",259,0) ;System being made SOR "RTN","EAS1071A",260,0) S PREF=$S(SYS="HEC":PREFHEC,1:PREFESR) "RTN","EAS1071A",261,0) ;Check messaging is settup for system being added "RTN","EAS1071A",262,0) I '$$Z07^EAS1071C(PREF,PREFHEC) D Q "RTN","EAS1071A",263,0) .S ERROR="MESSAGING NOT ENABLED FOR "_SYS "RTN","EAS1071A",264,0) .S RETURN=-1_"^"_ERROR "RTN","EAS1071A",265,0) .D ABORT2(RETURN,SYS_" as system of record") "RTN","EAS1071A",266,0) .S STOP=0 "RTN","EAS1071A",267,0) ; "RTN","EAS1071A",268,0) I SYS="ESR" D Q "RTN","EAS1071A",269,0) .;Disable HEC Z10/Z11 protocols "RTN","EAS1071A",270,0) .D UNLINK^EAS1071C(PREFHEC) Q:STOP "RTN","EAS1071A",271,0) .;Enable ESR Z10/Z11 protocols "RTN","EAS1071A",272,0) .D LINK^EAS1071C Q:STOP "RTN","EAS1071A",273,0) .;Return message "RTN","EAS1071A",274,0) .S ARR="ESR set as SOR" "RTN","EAS1071A",275,0) ; "RTN","EAS1071A",276,0) I SYS="HEC" D Q "RTN","EAS1071A",277,0) .;Disable ESR Z10/Z11 protocols "RTN","EAS1071A",278,0) .D UNLINK^EAS1071C(PREFESR) Q:STOP "RTN","EAS1071A",279,0) .;Enable HEC Z10/Z11 protocols "RTN","EAS1071A",280,0) .D LINK^EAS1071C Q:STOP "RTN","EAS1071A",281,0) .;Return message "RTN","EAS1071A",282,0) .S ARR="HEC set as SOR" "RTN","EAS1071A",283,0) Q "RTN","EAS1071B") 0^9^B26013480^n/a "RTN","EAS1071B",1,0) EAS1071B ;ALB/PJH - EAS*1*71; ; 11/27/07 3:02pm "RTN","EAS1071B",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EAS1071B",3,0) Q "RTN","EAS1071B",4,0) ; "RTN","EAS1071B",5,0) EN(ARR) ;ENTRY POINT "RTN","EAS1071B",6,0) ; "RTN","EAS1071B",7,0) N DA,DIK,LINE,LCT,NAM,PREFIX,RESULT "RTN","EAS1071B",8,0) ; "RTN","EAS1071B",9,0) S ARR="HEC messaging NOT disabled" "RTN","EAS1071B",10,0) ; "RTN","EAS1071B",11,0) ; Get site's Station # "RTN","EAS1071B",12,0) S PREFIX="VAMC "_$P($$SITE^VASITE,"^",3)_" " "RTN","EAS1071B",13,0) ; "RTN","EAS1071B",14,0) I $$SOR^EAS1071C(PREFIX,PREFIX) D Q "RTN","EAS1071B",15,0) .S ARR="Unable to disable messaging, HEC is SOR" "RTN","EAS1071B",16,0) ; "RTN","EAS1071B",17,0) ;Remove HEC client subscriber protocols from shared servers "RTN","EAS1071B",18,0) F LCT=1:1 S LINE=$T(PROTDAT+LCT) Q:$P(LINE,";",3)="END" D Q:STOP "RTN","EAS1071B",19,0) .S NAM=PREFIX_$P(LINE,";",3)_" CLIENT" "RTN","EAS1071B",20,0) .S SIEN101=$O(^ORD(101,"B",NAM,0)) "RTN","EAS1071B",21,0) .I +SIEN101=0 D Q "RTN","EAS1071B",22,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071B",23,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071B",24,0) ..D ERROR(RETURN,"Event Driver:"_NAM) "RTN","EAS1071B",25,0) .;If this is a SUBSCRIBER remove from SERVER "RTN","EAS1071B",26,0) .I $O(^ORD(101,"AB",SIEN101,0)) D REMOVE(SIEN101,NAM) "RTN","EAS1071B",27,0) ; "RTN","EAS1071B",28,0) ;Add disable text to HEC to ESR servers "RTN","EAS1071B",29,0) F LCT=1:1 S LINE=$T(PROTDAT1+LCT) Q:$P(LINE,";",3)="END" D "RTN","EAS1071B",30,0) .S NAM=PREFIX_$P(LINE,";",3) "RTN","EAS1071B",31,0) .;Insert disable text "RTN","EAS1071B",32,0) .S RESULT=$$EDP(NAM,"HEC Legacy to Site Messaging Inactivated") "RTN","EAS1071B",33,0) .I +RESULT<0 D ERROR(RESULT,"Event Driver:"_NAM) "RTN","EAS1071B",34,0) ; "RTN","EAS1071B",35,0) S:'STOP ARR="HEC messaging disabled" "RTN","EAS1071B",36,0) Q "RTN","EAS1071B",37,0) ; "RTN","EAS1071B",38,0) EDP(PNAME,DTXT) ;Remove Disable Text from Event Driver Protocols "RTN","EAS1071B",39,0) ; "RTN","EAS1071B",40,0) N DATA,FILE,DGENDA,RETURN,ERROR,DA "RTN","EAS1071B",41,0) S FILE=101 "RTN","EAS1071B",42,0) S IEN101=$O(^ORD(101,"B",PNAME,0)) "RTN","EAS1071B",43,0) I 'IEN101 D Q RETURN "RTN","EAS1071B",44,0) . S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071B",45,0) . S RETURN=-1_"^"_ERROR "RTN","EAS1071B",46,0) ; "RTN","EAS1071B",47,0) S DATA(2)=DTXT "RTN","EAS1071B",48,0) S RETURN=$$UPD^DGENDBS(FILE,IEN101,.DATA,.ERROR) "RTN","EAS1071B",49,0) I ERROR'=""!(+RETURN=0) S RETURN=-1_"^"_ERROR "RTN","EAS1071B",50,0) ; "RTN","EAS1071B",51,0) Q RETURN "RTN","EAS1071B",52,0) ; "RTN","EAS1071B",53,0) REMOVE(CLIENT,CNAM) ;Remove clients from server "RTN","EAS1071B",54,0) N DA,DIK,SERV,SNAM,SUB "RTN","EAS1071B",55,0) S SERV=0 "RTN","EAS1071B",56,0) F S SERV=$O(^ORD(101,"AB",CLIENT,SERV)) Q:'SERV D "RTN","EAS1071B",57,0) .S SUB=0,SNAM=$P($G(^ORD(101,SERV,0)),U) "RTN","EAS1071B",58,0) .F S SUB=$O(^ORD(101,"AB",CLIENT,SERV,SUB)) Q:'SUB D "RTN","EAS1071B",59,0) ..S DA(1)=SERV,DA=SUB,DIK="^ORD(101,"_DA(1)_",775," D ^DIK "RTN","EAS1071B",60,0) Q "RTN","EAS1071B",61,0) ; "RTN","EAS1071B",62,0) PROTDAT ;Vista to HEC clients on shared Event Drivers "RTN","EAS1071B",63,0) ;;ORU-Z07 "RTN","EAS1071B",64,0) ;;ORU-Z09 "RTN","EAS1071B",65,0) ;;ORF-Z07 "RTN","EAS1071B",66,0) ;;END "RTN","EAS1071B",67,0) ;;NOTE THAT THESE ARE HANDLED BY QRY^EAS1071A "RTN","EAS1071B",68,0) ;;QRY-Z10 "RTN","EAS1071B",69,0) ;;QRY-Z11 "RTN","EAS1071B",70,0) ;;END "RTN","EAS1071B",71,0) ; "RTN","EAS1071B",72,0) PROTDAT1 ;HEC to Vista Event Drivers to disable "RTN","EAS1071B",73,0) ;;ORU-Z04 SERVER H "RTN","EAS1071B",74,0) ;;ORU-Z05 SERVER "RTN","EAS1071B",75,0) ;;ORU-Z10 SERVER "RTN","EAS1071B",76,0) ;;ORU-Z11 SERVER "RTN","EAS1071B",77,0) ;;ORF-Z10 SERVER "RTN","EAS1071B",78,0) ;;ORF-Z11 SERVER "RTN","EAS1071B",79,0) ;;QRY-Z07 SERVER "RTN","EAS1071B",80,0) ;;MFN-ZEG SERVER "RTN","EAS1071B",81,0) ;;END "RTN","EAS1071B",82,0) ; "RTN","EAS1071B",83,0) RESET(ARR) ;Enable or Attach HEC protocols "RTN","EAS1071B",84,0) N DA,DIK,ERROR,IEN101,LINE,LCT,NAM,PREFIX,SIEN101,SNAM,STOP "RTN","EAS1071B",85,0) ; "RTN","EAS1071B",86,0) S ARR="HEC messaging NOT re enabled" "RTN","EAS1071B",87,0) ; "RTN","EAS1071B",88,0) ; Get site's Station # "RTN","EAS1071B",89,0) S PREFIX="VAMC "_$P($$SITE^VASITE,"^",3)_" ",STOP=0 "RTN","EAS1071B",90,0) ; "RTN","EAS1071B",91,0) ;Enable to Vista to HEC Legacy servers "RTN","EAS1071B",92,0) F LCT=1:1 S LINE=$T(PROTDAT1+LCT) Q:$P(LINE,";",3)="END" D "RTN","EAS1071B",93,0) .S NAM=PREFIX_$P(LINE,";",3) "RTN","EAS1071B",94,0) .;Remove disable text "RTN","EAS1071B",95,0) .S RESULT=$$EDP(NAM,"") "RTN","EAS1071B",96,0) .I +RESULT<0 D ERROR(RESULT,"Event Driver:"_NAM) "RTN","EAS1071B",97,0) ; "RTN","EAS1071B",98,0) ; "RTN","EAS1071B",99,0) ;Add HEC client protocols to shared servers "RTN","EAS1071B",100,0) F LCT=1:1 S LINE=$T(PROTDAT+LCT) Q:$P(LINE,";",3)="END" D "RTN","EAS1071B",101,0) .S FILE=101 "RTN","EAS1071B",102,0) .;Server protocol "RTN","EAS1071B",103,0) .S NAM=PREFIX_$P(LINE,";",3)_" SERVER" "RTN","EAS1071B",104,0) .I NAM["Z04" S NAM=NAM_" V" "RTN","EAS1071B",105,0) .S IEN101=$O(^ORD(101,"B",NAM,0)) "RTN","EAS1071B",106,0) .I 'IEN101 D Q RETURN "RTN","EAS1071B",107,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071B",108,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071B",109,0) .; "RTN","EAS1071B",110,0) .;Client protocol (subscriber) "RTN","EAS1071B",111,0) .S SNAM=PREFIX_$P(LINE,";",3)_" CLIENT" "RTN","EAS1071B",112,0) .I SNAM["Z04" S SNAM=SNAM_" V" "RTN","EAS1071B",113,0) .S SIEN101=$O(^ORD(101,"B",SNAM,0)) "RTN","EAS1071B",114,0) .I +SIEN101=0 D Q "RTN","EAS1071B",115,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071B",116,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071B",117,0) ..D ERROR(RETURN,"Subscriber:"_SNAM) "RTN","EAS1071B",118,0) .;Skip if already present "RTN","EAS1071B",119,0) .I $D(^ORD(101,IEN101,775,"B",SIEN101)) D Q "RTN","EAS1071B",120,0) ..D WARN(NAM,SNAM) "RTN","EAS1071B",121,0) .;Add subscriber to event driver "RTN","EAS1071B",122,0) .S RETURN=$$SUBSCR(IEN101,SIEN101) "RTN","EAS1071B",123,0) .I +RETURN<0 D ERROR(RETURN,"driver with Subscriber:"_SNAM) Q "RTN","EAS1071B",124,0) ; "RTN","EAS1071B",125,0) S:'STOP ARR="HEC messaging re enabled" "RTN","EAS1071B",126,0) Q "RTN","EAS1071B",127,0) ; "RTN","EAS1071B",128,0) ; "RTN","EAS1071B",129,0) ERROR(ERRMSG,SUBJ) ;Display Install Error message and set STOP "RTN","EAS1071B",130,0) ; "RTN","EAS1071B",131,0) S STOP=1 "RTN","EAS1071B",132,0) ; "RTN","EAS1071B",133,0) S ARR(1)="====================================================" "RTN","EAS1071B",134,0) S ARR(2)="= ERROR =" "RTN","EAS1071B",135,0) S ARR(3)="====================================================" "RTN","EAS1071B",136,0) S ARR(4)="When updating "_SUBJ "RTN","EAS1071B",137,0) S ARR(5)="====================================================" "RTN","EAS1071B",138,0) S ARR(5)="**ERROR MSG: "_$P(ERRMSG,"^",2) "RTN","EAS1071B",139,0) ; "RTN","EAS1071B",140,0) Q "RTN","EAS1071B",141,0) ; "RTN","EAS1071B",142,0) WARN(EDP,SP) ;Display Warning Message "RTN","EAS1071B",143,0) ; "RTN","EAS1071B",144,0) S ARR(1)="====================================================" "RTN","EAS1071B",145,0) S ARR(2)="= WARNING =" "RTN","EAS1071B",146,0) S ARR(3)="====================================================" "RTN","EAS1071B",147,0) S ARR(4)="When updating "_EDP "RTN","EAS1071B",148,0) S ARR(5)="====================================================" "RTN","EAS1071B",149,0) S ARR(5)="**"_SP_" is already defined**" "RTN","EAS1071B",150,0) ; "RTN","EAS1071B",151,0) Q "RTN","EAS1071B",152,0) ; "RTN","EAS1071B",153,0) SUBSCR(IEN101,SIEN101) ;Add client to event driver as a subscriber "RTN","EAS1071B",154,0) ; "RTN","EAS1071B",155,0) N DATA,DGENDA,ERROR,FILE,RETURN "RTN","EAS1071B",156,0) S DGENDA(1)=IEN101 "RTN","EAS1071B",157,0) S FILE=101.0775 "RTN","EAS1071B",158,0) S DATA(.01)=SIEN101 "RTN","EAS1071B",159,0) S RETURN=$$ADD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR) "RTN","EAS1071B",160,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071B",161,0) ; "RTN","EAS1071B",162,0) Q RETURN "RTN","EAS1071C") 0^10^B6862758^n/a "RTN","EAS1071C",1,0) EAS1071C ;ALB/PJH - ESR and HEC Messaging ; 11/27/07 3:02pm "RTN","EAS1071C",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EAS1071C",3,0) ; "RTN","EAS1071C",4,0) LINK ;Link QRY Z10/Z11 protocols to shared servers "RTN","EAS1071C",5,0) N ERROR,FILE,IEN101,LINE,LNCNT,RETURN,SIEN101,SNAM "RTN","EAS1071C",6,0) S LNCNT=1 "RTN","EAS1071C",7,0) F S LINE=$T(PROTDAT1+LNCNT) Q:$P(LINE,";",3)="END" D Q:STOP "RTN","EAS1071C",8,0) .S NAM=PREFHEC_$P(LINE,";",3)_" SERVER" "RTN","EAS1071C",9,0) .S IEN101=$O(^ORD(101,"B",NAM,0)) "RTN","EAS1071C",10,0) .I +IEN101=0 D Q "RTN","EAS1071C",11,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071C",12,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071C",13,0) ..D ABORT2^EAS1071A(RETURN,"Event Driver:"_NAM) "RTN","EAS1071C",14,0) .; "RTN","EAS1071C",15,0) .;Client Protocol "RTN","EAS1071C",16,0) .S SNAM=@("PREF"_SYS) "RTN","EAS1071C",17,0) .S SNAM=SNAM_$P(LINE,";",3)_" CLIENT" "RTN","EAS1071C",18,0) .S SIEN101=$O(^ORD(101,"B",SNAM,0)) "RTN","EAS1071C",19,0) .I +SIEN101=0 D Q "RTN","EAS1071C",20,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071C",21,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071C",22,0) ..D ABORT2^EAS1071A(RETURN,"Subscriber:"_SNAM) "RTN","EAS1071C",23,0) .;Skip if already present "RTN","EAS1071C",24,0) .I $D(^ORD(101,IEN101,775,"B",SIEN101)) D Q "RTN","EAS1071C",25,0) ..D WARN^EAS1071A(NAM,SNAM) "RTN","EAS1071C",26,0) ..S LNCNT=LNCNT+1 "RTN","EAS1071C",27,0) .;Add subscriber to event driver "RTN","EAS1071C",28,0) .S RETURN=$$SUBSCR^EAS1071A(IEN101,SIEN101) "RTN","EAS1071C",29,0) .I +RETURN<0 D ABORT2^EAS1071A(RETURN,"driver with Subscriber:"_SNAM) Q "RTN","EAS1071C",30,0) .S LNCNT=LNCNT+1 "RTN","EAS1071C",31,0) Q "RTN","EAS1071C",32,0) ; "RTN","EAS1071C",33,0) UNLINK(PREF) ;Remove Z10/Z11 client subscriber protocols from shared servers "RTN","EAS1071C",34,0) F LCT=1:1 S LINE=$T(PROTDAT1+LCT) Q:$P(LINE,";",3)="END" D Q:STOP "RTN","EAS1071C",35,0) .S NAM=PREF_$P(LINE,";",3)_" CLIENT" "RTN","EAS1071C",36,0) .S SIEN101=$O(^ORD(101,"B",NAM,0)) "RTN","EAS1071C",37,0) .I +SIEN101=0 D Q "RTN","EAS1071C",38,0) ..S ERROR="IEN OF RECORD TO BE UPDATED NOT FOUND" "RTN","EAS1071C",39,0) ..S RETURN=-1_"^"_ERROR "RTN","EAS1071C",40,0) ..D ABORT2^EAS1071A(RETURN,"Event Driver:"_NAM) "RTN","EAS1071C",41,0) .;If this is a SUBSCRIBER remove from SERVER "RTN","EAS1071C",42,0) .I $O(^ORD(101,"AB",SIEN101,0)) D REMOVE^EAS1071A(SIEN101,NAM) "RTN","EAS1071C",43,0) Q "RTN","EAS1071C",44,0) ; "RTN","EAS1071C",45,0) PROTDAT1 ; "RTN","EAS1071C",46,0) ;;QRY-Z10 "RTN","EAS1071C",47,0) ;;QRY-Z11 "RTN","EAS1071C",48,0) ;;END "RTN","EAS1071C",49,0) ; "RTN","EAS1071C",50,0) SOR(PREF,PREFHEC) ;Check if SOR "RTN","EAS1071C",51,0) N IENC,IENS,NAMC,NAMS "RTN","EAS1071C",52,0) S NAMS=PREFHEC_"QRY-Z10 SERVER" "RTN","EAS1071C",53,0) ;get server ien "RTN","EAS1071C",54,0) S IENS=$O(^ORD(101,"B",NAMS,0)) Q:'IENS 0 "RTN","EAS1071C",55,0) ;check subscriber protocols "RTN","EAS1071C",56,0) S IENC=+$G(^ORD(101,IENS,775,1,0)) Q:'IENC 0 "RTN","EAS1071C",57,0) ;Check subscriber if is for this system "RTN","EAS1071C",58,0) I $P($G(^ORD(101,IENC,0)),U)[PREF Q 1 "RTN","EAS1071C",59,0) ; "RTN","EAS1071C",60,0) Q 0 "RTN","EAS1071C",61,0) ; "RTN","EAS1071C",62,0) Z07(PREF,PREFHEC) ;Check if Z07 messaging is set up "RTN","EAS1071C",63,0) N IENC,IENS,FOUND,NAMC,NAMS "RTN","EAS1071C",64,0) S NAMC=PREF_"ORU-Z07 CLIENT",NAMS=PREFHEC_"ORU-Z07 SERVER" "RTN","EAS1071C",65,0) ;get server ien "RTN","EAS1071C",66,0) S IENS=$O(^ORD(101,"B",NAMS,0)) Q:'IENS 0 "RTN","EAS1071C",67,0) ;check subscriber protocols "RTN","EAS1071C",68,0) S IENC=0,FOUND=0 "RTN","EAS1071C",69,0) F S IENC=$O(^ORD(101,IENS,775,"B",IENC)) Q:'IENC D Q:FOUND "RTN","EAS1071C",70,0) .;Check subscriber if is for this system "RTN","EAS1071C",71,0) .S:$P($G(^ORD(101,IENC,0)),U)=NAMC FOUND=1 "RTN","EAS1071C",72,0) ; "RTN","EAS1071C",73,0) Q FOUND "RTN","EAS1071P") 0^1^B43511372^n/a "RTN","EAS1071P",1,0) EAS1071P ;ALB/PJH - Patch Post-Install functions EAS*1*71 ; 11/27/07 3:03pm "RTN","EAS1071P",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EAS1071P",3,0) Q "RTN","EAS1071P",4,0) ; "RTN","EAS1071P",5,0) EN ;ENTRY POINT "RTN","EAS1071P",6,0) ; "RTN","EAS1071P",7,0) N ADDR,AN,PORT,SLLN,STATION,TCPDATA,AN,STOP,VER,DA,FILE,RET,ERROR "RTN","EAS1071P",8,0) ; "RTN","EAS1071P",9,0) ; Get site's Station # "RTN","EAS1071P",10,0) S STATION=$P($$SITE^VASITE,"^",3) "RTN","EAS1071P",11,0) ; "RTN","EAS1071P",12,0) S STOP=0 "RTN","EAS1071P",13,0) Q:$$SETLL16(.SLLN) "RTN","EAS1071P",14,0) Q:$$SETAPP(STATION,.AN) "RTN","EAS1071P",15,0) D PROTOCOL(STATION,SLLN,.AN) "RTN","EAS1071P",16,0) Q "RTN","EAS1071P",17,0) ; "RTN","EAS1071P",18,0) SETLL16(SLLN) ;Create Logical link "RTN","EAS1071P",19,0) N ADDR,PORT,RET,VISN,M,IENS "RTN","EAS1071P",20,0) ; "RTN","EAS1071P",21,0) S PORT="" ;Vitria Port# "RTN","EAS1071P",22,0) S ADDR="" ;IP address is modified by EAS1072P "RTN","EAS1071P",23,0) S SLLN="LLESROUT" "RTN","EAS1071P",24,0) S RET=$$LL16^EAS1071Q(SLLN,"TCP","NC",10,ADDR,PORT,"C","N","") "RTN","EAS1071P",25,0) I +RET<0 D ERROR(RET,"ESR Send Link:"_SLLN) Q 1 "RTN","EAS1071P",26,0) LL16EXIT Q STOP "RTN","EAS1071P",27,0) ; "RTN","EAS1071P",28,0) ; "RTN","EAS1071P",29,0) SETAPP(STATION,AN) ; "RTN","EAS1071P",30,0) ;INPUT STATION = Station # "RTN","EAS1071P",31,0) ; AN = Array containing all the Application Names "RTN","EAS1071P",32,0) ; "RTN","EAS1071P",33,0) ;OUTPUT 0 : Success, 1 : Error "RTN","EAS1071P",34,0) ; "RTN","EAS1071P",35,0) ;PURPOSE Create the sending and receiving application definitions. "RTN","EAS1071P",36,0) ; "RTN","EAS1071P",37,0) N RECVAPP,SENDAPP "RTN","EAS1071P",38,0) S (SENDAPP,AN("S"))="VAMC "_STATION "RTN","EAS1071P",39,0) I '$O(^HL(771,"B",SENDAPP,0)) D Q STOP "RTN","EAS1071P",40,0) .D ERROR("^HL7 APPLICATION PARAMETER "_SENDAPP_" NOT FOUND","Client Protocols - Install aborted") "RTN","EAS1071P",41,0) ; "RTN","EAS1071P",42,0) ANR S AN("R")="ESR" "RTN","EAS1071P",43,0) S RECVAPP=$$APP^EAS1071Q(AN("R"),"a","200ESR","USA") "RTN","EAS1071P",44,0) I +RECVAPP<0 D ERROR(RECVAPP,"Receiving App:"_AN("R")) "RTN","EAS1071P",45,0) APPEXIT Q STOP "RTN","EAS1071P",46,0) ; "RTN","EAS1071P",47,0) ; "RTN","EAS1071P",48,0) PROTOCOL(STATION,SLLN,AN) ; "RTN","EAS1071P",49,0) ;INPUT STATION = Station # "RTN","EAS1071P",50,0) ; RLLN = Receiving Logical Link Name "RTN","EAS1071P",51,0) ; SLLN = Sending Logical Link Name "RTN","EAS1071P",52,0) ; AN = Array containing the Application Names "RTN","EAS1071P",53,0) ; "RTN","EAS1071P",54,0) ;OUTPUT None "RTN","EAS1071P",55,0) ; "RTN","EAS1071P",56,0) ;PURPOSE Using the table in line label PROTDAT create the "RTN","EAS1071P",57,0) ; protocols (Subscriber and Event Driver) for the "RTN","EAS1071P",58,0) ; ESR/Vitria TCP/IP interfaces "RTN","EAS1071P",59,0) ; "RTN","EAS1071P",60,0) N RESULT,SIEN,V,N,N1,LNCNT,LINE,PROTRET,NAM "RTN","EAS1071P",61,0) S N1="EAS ESR "_STATION,V="2.3.1" "RTN","EAS1071P",62,0) ; "RTN","EAS1071P",63,0) S LNCNT=1 "RTN","EAS1071P",64,0) F S LINE=$T(PROTDAT+LNCNT) Q:$P(LINE,";",3)="END" D Q:STOP "RTN","EAS1071P",65,0) . K D,RESULT "RTN","EAS1071P",66,0) . F N=3:1 Q:$P(LINE,";",N)="LEND" S D(N)=$$V($P(LINE,";",N)) "RTN","EAS1071P",67,0) . S NAM=D(3)_D(4)_D(5) "RTN","EAS1071P",68,0) . D:NAM["CLIENT" "RTN","EAS1071P",69,0) . . S SIEN=$$SP^EAS1071Q(NAM,D(6),D(7),D(8),D(9),D(10)) "RTN","EAS1071P",70,0) . . I +SIEN<0 D ERROR(SIEN,"Subscriber:"_NAM) "RTN","EAS1071P",71,0) . D:NAM["SERVER" "RTN","EAS1071P",72,0) . . N TMPNAM,ITEMTXT "RTN","EAS1071P",73,0) . . S TMPNAM=D(6)_D(7)_$P(NAM,"SERVER ",2) "RTN","EAS1071P",74,0) . . S ITEMTXT=$$GETIT(TMPNAM) "RTN","EAS1071P",75,0) . . S RESULT=$$EDP^EAS1071Q(NAM,D(6),D(7),D(8),D(9),D(10),D(11),D(12),ITEMTXT) "RTN","EAS1071P",76,0) . . I +RESULT<0 D ERROR(RESULT,"Event Driver:"_NAM) "RTN","EAS1071P",77,0) . S LNCNT=LNCNT+1 "RTN","EAS1071P",78,0) K D "RTN","EAS1071P",79,0) Q "RTN","EAS1071P",80,0) ; "RTN","EAS1071P",81,0) ERROR(ERRMSG,SUBJ) ;Display error message and set STOP=1 "RTN","EAS1071P",82,0) ; "RTN","EAS1071P",83,0) N ARR "RTN","EAS1071P",84,0) S STOP=1 "RTN","EAS1071P",85,0) S ARR(1)="====================================================" "RTN","EAS1071P",86,0) S ARR(2)="= ERROR =" "RTN","EAS1071P",87,0) S ARR(3)="====================================================" "RTN","EAS1071P",88,0) S ARR(4)="When creating "_SUBJ "RTN","EAS1071P",89,0) S ARR(5)="====================================================" "RTN","EAS1071P",90,0) S ARR(6)="**ERROR MSG: "_$P(ERRMSG,"^",2) "RTN","EAS1071P",91,0) ; "RTN","EAS1071P",92,0) D BMES^XPDUTL(.ARR) "RTN","EAS1071P",93,0) ; "RTN","EAS1071P",94,0) Q "RTN","EAS1071P",95,0) ; "RTN","EAS1071P",96,0) V(VALUE) ;FUNCTION: If variable then pass back value of it. "RTN","EAS1071P",97,0) ; "RTN","EAS1071P",98,0) I $E(VALUE)="@" Q @($E(VALUE,2,$L(VALUE))) "RTN","EAS1071P",99,0) Q VALUE "RTN","EAS1071P",100,0) ; "RTN","EAS1071P",101,0) GETIT(N) ;FUNCTION: Given Message Type and Event Type return the "RTN","EAS1071P",102,0) ; Transmission Description. "RTN","EAS1071P",103,0) ; "RTN","EAS1071P",104,0) Q:N="ORUZEG" "ENROLLMENT GROUP THRESHOLD/Unsolicited ESR to VAMC" "RTN","EAS1071P",105,0) Q:N="ORUZ04H" "INSURANCE/Unsolicited ESR to VAMC" "RTN","EAS1071P",106,0) Q:N="ORUZ05" "DEMOGRAPHIC DATA/Unsolicited ESR to VAMC" "RTN","EAS1071P",107,0) Q:N="ORUZ10" "INCOME TEST DATA/Unsolicited ESR to VAMC" "RTN","EAS1071P",108,0) Q:N="ORUZ11" "ENROLLMENT/ELIGIBILITY DATA/Unsolicited ESR to VAMC" "RTN","EAS1071P",109,0) Q:N="ORFZ10" "FINANCIAL QUERY/Reply ESR to VAMC" "RTN","EAS1071P",110,0) Q:N="ORFZ11" "ENROLLMENT/ELIGIBILITY QUERY/Reply ESR to VAMC" "RTN","EAS1071P",111,0) Q:N="QRYZ07" "IVM INDIVIDUAL QUERY FULL DATA/Query ESR to VAMC" "RTN","EAS1071P",112,0) Q "" "RTN","EAS1071P",113,0) ; "RTN","EAS1071P",114,0) PROTDAT ;;VAMC SIDE PROTOCOLS "RTN","EAS1071P",115,0) ;;@N1;; ORU-Z04 CLIENT H;@SLLN;@AN("S");ACK;;D ORU^EASPREC3;LEND "RTN","EAS1071P",116,0) ;;@N1;; ORU-Z04 SERVER H;ORU;Z04;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",117,0) ;;@N1;; ORU-Z05 CLIENT;@SLLN;@AN("S");ACK;;D ORU^EASPREC3;LEND "RTN","EAS1071P",118,0) ;;@N1;; ORU-Z05 SERVER;ORU;Z05;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",119,0) ;;@N1;; ORU-Z07 CLIENT;@SLLN;@AN("R");ACK;;;LEND "RTN","EAS1071P",120,0) ;;@N1;; ORU-Z09 CLIENT;@SLLN;@AN("R");ACK;;;LEND "RTN","EAS1071P",121,0) ;;@N1;; ORU-Z10 CLIENT;@SLLN;@AN("S");ACK;;D ORU^EASPREC3;LEND "RTN","EAS1071P",122,0) ;;@N1;; ORU-Z10 SERVER;ORU;Z10;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",123,0) ;;@N1;; ORU-Z11 CLIENT;@SLLN;@AN("S");ACK;;D ORU^EASPREC3;LEND "RTN","EAS1071P",124,0) ;;@N1;; ORU-Z11 SERVER;ORU;Z11;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",125,0) ;;@N1;; ORF-Z07 CLIENT;@SLLN;@AN("R");ACK;;;LEND "RTN","EAS1071P",126,0) ;;@N1;; ORF-Z10 CLIENT;@SLLN;@AN("S");ACK;;D ORF^EASCM;LEND "RTN","EAS1071P",127,0) ;;@N1;; ORF-Z10 SERVER;ORF;Z10;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",128,0) ;;@N1;; ORF-Z11 CLIENT;@SLLN;@AN("S");ACK;;D ORF^EASCM;LEND "RTN","EAS1071P",129,0) ;;@N1;; ORF-Z11 SERVER;ORF;Z11;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",130,0) ;;@N1;; QRY-Z07 CLIENT;@SLLN;@AN("S");ORF;Z07;D QRY^EASPREC4;LEND "RTN","EAS1071P",131,0) ;;@N1;; QRY-Z07 SERVER;QRY;Z07;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",132,0) ;;@N1;; QRY-Z10 CLIENT;@SLLN;@AN("R");ORF;Z10;;LEND "RTN","EAS1071P",133,0) ;;@N1;; QRY-Z11 CLIENT;@SLLN;@AN("R");ORF;Z11;;LEND "RTN","EAS1071P",134,0) ;;@N1;; MFN-ZEG CLIENT;@SLLN;@AN("S");MFK;ZEG;D MFN^EASEGT2;LEND "RTN","EAS1071P",135,0) ;;@N1;; MFN-ZEG SERVER;MFN;ZEG;@V;@AN("R");;@SIEN;ESR-to-Site Messaging Inactive;LEND "RTN","EAS1071P",136,0) ;;END "RTN","EAS1071P",137,0) ; "RTN","EAS1071P",138,0) ;Utilities section "RTN","EAS1071P",139,0) ; "RTN","EAS1071P",140,0) RESET ;Delete all existing EAS ESR protocols (in the current list) "RTN","EAS1071P",141,0) Q "RTN","EAS1071P",142,0) N DA,DIK,DIR,DIROUT,DIRUT,DTOUT,DUOUT,LINE,LCT,NAM,PREFIX "RTN","EAS1071P",143,0) ;Prompt "RTN","EAS1071P",144,0) S DIR(0)="Y",DIR("B")="NO" "RTN","EAS1071P",145,0) S DIR("A")="Are you really sure you wish to proceed:" "RTN","EAS1071P",146,0) S DIR("A",1)="**WARNING**" "RTN","EAS1071P",147,0) S DIR("A",2)="" "RTN","EAS1071P",148,0) S DIR("A",3)="This utility will delete all ESR protocols from Vista" "RTN","EAS1071P",149,0) S DIR("A",4)="" "RTN","EAS1071P",150,0) D ^DIR "RTN","EAS1071P",151,0) I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) W !!,"Aborted by user" Q "RTN","EAS1071P",152,0) I 'Y W !!,"Aborted by user" Q "RTN","EAS1071P",153,0) ; "RTN","EAS1071P",154,0) W ! "RTN","EAS1071P",155,0) ; Get site's Station # "RTN","EAS1071P",156,0) S PREFIX="EAS ESR "_$P($$SITE^VASITE,"^",3) "RTN","EAS1071P",157,0) F LCT=1:1 S LINE=$T(PROTDAT+LCT) Q:$P(LINE,";",3)="END" D "RTN","EAS1071P",158,0) .S NAM=PREFIX_$P(LINE,";",5) "RTN","EAS1071P",159,0) .S DA=$O(^ORD(101,"B",NAM,0)) I 'DA W !,NAM,?35,"NOT FOUND" Q "RTN","EAS1071P",160,0) .;If this is a SUBSCRIBER remove from SERVER "RTN","EAS1071P",161,0) .I $O(^ORD(101,"AB",DA,0)) D REMOVE(DA,NAM) "RTN","EAS1071P",162,0) .;Delete the protocol "RTN","EAS1071P",163,0) .S DIK="^ORD(101," "RTN","EAS1071P",164,0) .D ^DIK "RTN","EAS1071P",165,0) .W !,NAM,?35,"DELETED" "RTN","EAS1071P",166,0) Q "RTN","EAS1071P",167,0) ; "RTN","EAS1071P",168,0) REMOVE(CLIENT,CNAM) ;Remove clients from server "RTN","EAS1071P",169,0) N DA,DIK,SERV,SNAM,SUB "RTN","EAS1071P",170,0) S SERV=0 "RTN","EAS1071P",171,0) F S SERV=$O(^ORD(101,"AB",CLIENT,SERV)) Q:'SERV D "RTN","EAS1071P",172,0) .S SUB=0,SNAM=$P($G(^ORD(101,SERV,0)),U) "RTN","EAS1071P",173,0) .F S SUB=$O(^ORD(101,"AB",CLIENT,SERV,SUB)) Q:'SUB D "RTN","EAS1071P",174,0) ..S DA(1)=SERV,DA=SUB,DIK="^ORD(101,"_DA(1)_",775," D ^DIK "RTN","EAS1071P",175,0) ..W !,CNAM,?35,"REMOVED FROM : ",SNAM "RTN","EAS1071P",176,0) Q "RTN","EAS1071Q") 0^2^B23165038^n/a "RTN","EAS1071Q",1,0) EAS1071Q ;ALB/PJH - Patch Post-Install functions EAS*1*71 ; 11/27/07 3:03pm "RTN","EAS1071Q",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EAS1071Q",3,0) ; "RTN","EAS1071Q",4,0) Q ;Entry Points Only "RTN","EAS1071Q",5,0) ; "RTN","EAS1071Q",6,0) ;Functions are called by EAS1071P "RTN","EAS1071Q",7,0) ; "RTN","EAS1071Q",8,0) LL16(LLNAME,LLPTYP,DEVTYP,QSIZE,TCPADDR,TCPPORT,TCPSTYP,PERSIST,STNODE) ; "RTN","EAS1071Q",9,0) ;INPUT LLNAME = Logical Link Name (ex. "LL HEC 500") "RTN","EAS1071Q",10,0) ; LLPTYP = LLP Type (ex. "TCP") "RTN","EAS1071Q",11,0) ; DEVTYP = Device Type - Systems Monitor - display ONLY "RTN","EAS1071Q",12,0) ; QSIZE = Queue Size "RTN","EAS1071Q",13,0) ; TCPADDR = TCP/IP Address "RTN","EAS1071Q",14,0) ; TCPPORT = TCP/IP Port # "RTN","EAS1071Q",15,0) ; TCPSTYP = TCP/IP Service Type "RTN","EAS1071Q",16,0) ; C - Client (Sender) "RTN","EAS1071Q",17,0) ; S - Single Listener "RTN","EAS1071Q",18,0) ; M - Multi Listener "RTN","EAS1071Q",19,0) ; PERSIST = Is connection persistent Y or N "RTN","EAS1071Q",20,0) ; STNODE = Startup Node - TaskMan Node to start on "RTN","EAS1071Q",21,0) ; "RTN","EAS1071Q",22,0) ;OUTPUT IEN of entry (#870) Success "RTN","EAS1071Q",23,0) ; -1^Error Message Error "RTN","EAS1071Q",24,0) ; "RTN","EAS1071Q",25,0) ;PURPOSE Create a Logical Link for TCP/IP transmissions. "RTN","EAS1071Q",26,0) ; "RTN","EAS1071Q",27,0) N FILE,DATA,RETURN,DEFINED,ERROR,DA,DGENDA "RTN","EAS1071Q",28,0) S FILE=870 "RTN","EAS1071Q",29,0) ; If already exists then skip "RTN","EAS1071Q",30,0) ; "RTN","EAS1071Q",31,0) Q:+$O(^HLCS(870,"B",LLNAME,0))>0 "" "RTN","EAS1071Q",32,0) ; "RTN","EAS1071Q",33,0) ; set v1.6 field values "RTN","EAS1071Q",34,0) S DATA(.01)=LLNAME ;LOGICAL LINK NAME "RTN","EAS1071Q",35,0) S DATA(2)=$O(^HLCS(869.1,"B",LLPTYP,0)) ;LLP TYPE "RTN","EAS1071Q",36,0) S DATA(3)=DEVTYP ;QUEUE TYPE "RTN","EAS1071Q",37,0) ;S DATA(4.5)=1 ;AUTOSTART "RTN","EAS1071Q",38,0) S DATA(21)=QSIZE ;QUEUE SIZE "RTN","EAS1071Q",39,0) D:TCPSTYP="C" ;IF CLIENT(SENDER) "RTN","EAS1071Q",40,0) . S DATA(200.02)=3 ;RE-TRANSMISSION ATTEMPTS "RTN","EAS1071Q",41,0) . S DATA(200.021)="R" ;EXCEED RE-TRANSMISSION "RTN","EAS1071Q",42,0) . S DATA(200.04)=90 ;READ TIMEOUT "RTN","EAS1071Q",43,0) . S DATA(200.05)=270 ;ACK TIMEOUT "RTN","EAS1071Q",44,0) S DATA(400.01)=TCPADDR ;TCP/IP ADDRESS "RTN","EAS1071Q",45,0) S DATA(400.02)=TCPPORT ;TCP/IP PORT "RTN","EAS1071Q",46,0) S DATA(400.03)=TCPSTYP ;TCP/IP SERVICE TYPE "RTN","EAS1071Q",47,0) S DATA(400.04)=PERSIST ;PERSISTENT "RTN","EAS1071Q",48,0) S DATA(400.06)=STNODE ;STARTUP NODE "RTN","EAS1071Q",49,0) S DATA(14)=1 ;SUSPENDED "RTN","EAS1071Q",50,0) ; "RTN","EAS1071Q",51,0) S RETURN=$$ADD^DGENDBS(FILE,"",.DATA,.ERROR) "RTN","EAS1071Q",52,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071Q",53,0) ; "RTN","EAS1071Q",54,0) Q RETURN "RTN","EAS1071Q",55,0) ; "RTN","EAS1071Q",56,0) APP(ANAME,STATUS,STATION,COUNTRY) ; "RTN","EAS1071Q",57,0) ;INPUT ANAME = Application Name (ex. "HEC 500") "RTN","EAS1071Q",58,0) ; STATUS = "a"CTIVE or "i"INACTIVE "RTN","EAS1071Q",59,0) ; STATION = STATION # (ex. 500) "RTN","EAS1071Q",60,0) ; COUNTRY = COUNTRY NAME (ex. "USA") "RTN","EAS1071Q",61,0) ; "RTN","EAS1071Q",62,0) ;OUTPUT IEN of entry (#771) Success "RTN","EAS1071Q",63,0) ; -1^Error Message Error "RTN","EAS1071Q",64,0) ; "RTN","EAS1071Q",65,0) ;PURPOSE Create an Application "RTN","EAS1071Q",66,0) ; "RTN","EAS1071Q",67,0) N DATA,FILE,RETURN,ERROR,DA "RTN","EAS1071Q",68,0) S FILE=771 "RTN","EAS1071Q",69,0) ; If already exists then skip "RTN","EAS1071Q",70,0) ; "RTN","EAS1071Q",71,0) Q:+$O(^HL(771,"B",ANAME,0))>0 "" "RTN","EAS1071Q",72,0) S DATA(.01)=ANAME "RTN","EAS1071Q",73,0) S DATA(2)=STATUS "RTN","EAS1071Q",74,0) S DATA(3)=STATION "RTN","EAS1071Q",75,0) S DATA(7)=$O(^HL(779.004,"B",COUNTRY,0)) "RTN","EAS1071Q",76,0) S RETURN=$$ADD^DGENDBS(FILE,"",.DATA,.ERROR) "RTN","EAS1071Q",77,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071Q",78,0) Q RETURN "RTN","EAS1071Q",79,0) ; "RTN","EAS1071Q",80,0) SP(PNAME,LL,RECVAPP,RMSGTYP,REVTTYP,MSGPRTN) ; "RTN","EAS1071Q",81,0) ;INPUT PNAME = Protocol Name "RTN","EAS1071Q",82,0) ; LL = Logical Link Name (ex. "LL VAMC 500") "RTN","EAS1071Q",83,0) ; RECVAPP = Receiving Application Name (ex. "VAMC 500") "RTN","EAS1071Q",84,0) ; RMSGTYP = Response Message Type (ex. "ACK") "RTN","EAS1071Q",85,0) ; REVTTYP = Response Event Type. Usually empty, used more "RTN","EAS1071Q",86,0) ; in response to a Query with an ORF message. "RTN","EAS1071Q",87,0) ; MSGPRTN = Message Processing Routine - Routine to parse "RTN","EAS1071Q",88,0) ; regular transmission of data - MUMPS format "RTN","EAS1071Q",89,0) ; (ex. "D ^IVMBORU") "RTN","EAS1071Q",90,0) ; "RTN","EAS1071Q",91,0) ;OUTPUT IEN entry (#101) for Subscriber Protocol Success "RTN","EAS1071Q",92,0) ; -1^Error Message "RTN","EAS1071Q",93,0) ; "RTN","EAS1071Q",94,0) ;PURPOSE Create a Subscriber Protocol "RTN","EAS1071Q",95,0) ; "RTN","EAS1071Q",96,0) N DATA,FILE,RETURN,ERROR,DA,DGENDA "RTN","EAS1071Q",97,0) S FILE=101 "RTN","EAS1071Q",98,0) ; If already exists then skip "RTN","EAS1071Q",99,0) ; "RTN","EAS1071Q",100,0) Q:+$O(^ORD(101,"B",PNAME,0))>0 "" "RTN","EAS1071Q",101,0) ; "RTN","EAS1071Q",102,0) S DATA(.01)=PNAME ;PROTOCOL NAME "RTN","EAS1071Q",103,0) S DATA(4)="S" ;PROTOCOL TYPE "RTN","EAS1071Q",104,0) S DATA(770.11)=$O(^HL(771.2,"B",RMSGTYP,0)) ;RESPONSE MSG TYPE "RTN","EAS1071Q",105,0) S DATA(770.2)=$O(^HL(771,"B",RECVAPP,0)) ;RECEIVING APP "RTN","EAS1071Q",106,0) S:REVTTYP]"" DATA(770.4)=$O(^HL(779.001,"B",REVTTYP,0)) ;EVENT TYPE "RTN","EAS1071Q",107,0) S DATA(770.7)=$O(^HLCS(870,"B",LL,0)) ;LOGICAL LINK "RTN","EAS1071Q",108,0) S DATA(771)=MSGPRTN ;MSG PROCESSING RTN "RTN","EAS1071Q",109,0) S DATA(773.1)=1 ;SEND FACILITY REQUIRED "RTN","EAS1071Q",110,0) S DATA(773.2)=1 ;RECV FACILITY REQUIRED "RTN","EAS1071Q",111,0) S RETURN=$$ADD^DGENDBS(FILE,"",.DATA,.ERROR) "RTN","EAS1071Q",112,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071Q",113,0) Q RETURN "RTN","EAS1071Q",114,0) ; "RTN","EAS1071Q",115,0) EDP(PNAME,MTYP,ETYP,VER,SENDAPP,ACKPRTN,SUBIEN,DTXT,ITEMTXT) ; "RTN","EAS1071Q",116,0) ;INPUT PNAME = Protocol Name "RTN","EAS1071Q",117,0) ; MTYP = Message Type Name (ex. "ORU") "RTN","EAS1071Q",118,0) ; ETYP = Event Type Name (ex. "Z09") "RTN","EAS1071Q",119,0) ; VER = HL7 Version # (ex. 2.3.1) "RTN","EAS1071Q",120,0) ; SENDAPP = Sending Application Name (ex. "VAMC 290") "RTN","EAS1071Q",121,0) ; ACKPRTN = Acknowledgement Processing Routine - "RTN","EAS1071Q",122,0) ; Routine to parse an ACK transmission - "RTN","EAS1071Q",123,0) ; MUMPs format (ex. "D ^IVMBACK") "RTN","EAS1071Q",124,0) ; SUBIEN = IEN of Subscriber Protocol in ^ORD(101) "RTN","EAS1071Q",125,0) ; DTXT = Disable Text "RTN","EAS1071Q",126,0) ; ITEMTXT = Item Text "RTN","EAS1071Q",127,0) ; "RTN","EAS1071Q",128,0) ;OUTPUT IEN entry (#101) of Event Driver Protocol Success "RTN","EAS1071Q",129,0) ; -1^Error Message Error "RTN","EAS1071Q",130,0) ; "RTN","EAS1071Q",131,0) ;PURPOSE Create an Event Driver Protocol and the Sub-File to "RTN","EAS1071Q",132,0) ; contain pointers to the Subscriber Protocol file "RTN","EAS1071Q",133,0) ; "RTN","EAS1071Q",134,0) N DATA,FILE,DGENDA,RETURN,ERROR,DA "RTN","EAS1071Q",135,0) S FILE=101 "RTN","EAS1071Q",136,0) ; If already exists then skip "RTN","EAS1071Q",137,0) ; "RTN","EAS1071Q",138,0) Q:+$O(^ORD(101,"B",PNAME,0))>0 "" "RTN","EAS1071Q",139,0) ; "RTN","EAS1071Q",140,0) S DATA(.01)=PNAME ;PROTOCOL NAME "RTN","EAS1071Q",141,0) S DATA(1)=ITEMTXT ;ITEM TEXT "RTN","EAS1071Q",142,0) S DATA(2)=DTXT ;DISABLE TEXT "RTN","EAS1071Q",143,0) S DATA(4)="E" ;PROTOCOL TYPE "RTN","EAS1071Q",144,0) S DATA(5)=+$G(DUZ) ;CREATOR "RTN","EAS1071Q",145,0) S DATA(770.1)=$O(^HL(771,"B",SENDAPP,0)) ;SENDING APP "RTN","EAS1071Q",146,0) S DATA(770.3)=$O(^HL(771.2,"B",MTYP,0)) ;MSG TYPE "RTN","EAS1071Q",147,0) S DATA(770.4)=$O(^HL(779.001,"B",ETYP,0)) ;EVENT TYPE "RTN","EAS1071Q",148,0) S DATA(770.8)=$O(^HL(779.003,"B","AL",0)) ;ACCEPT ACK CODE "RTN","EAS1071Q",149,0) S DATA(770.9)=$O(^HL(779.003,"B","AL",0)) ;APPLICATION ACK TYPE "RTN","EAS1071Q",150,0) S DATA(770.95)=$O(^HL(771.5,"B",VER,0)) ;VERSION ID "RTN","EAS1071Q",151,0) S DATA(772)=ACKPRTN ;ACK PROCESSING RTN "RTN","EAS1071Q",152,0) S RETURN=$$ADD^DGENDBS(FILE,"",.DATA,.ERROR) "RTN","EAS1071Q",153,0) I ERROR'=""!(+RETURN=0) S RETURN=-1_"^"_ERROR G EDPEXIT "RTN","EAS1071Q",154,0) S DGENDA(1)=RETURN "RTN","EAS1071Q",155,0) ; "RTN","EAS1071Q",156,0) ; ADD SUBSCRIBER SUB-FILE TO EVENT DRIVER PROTOCOL "RTN","EAS1071Q",157,0) S FILE=101.0775 "RTN","EAS1071Q",158,0) K DATA "RTN","EAS1071Q",159,0) S DATA(.01)=SUBIEN "RTN","EAS1071Q",160,0) S RETURN=$$ADD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR) "RTN","EAS1071Q",161,0) S:ERROR'=""!(+RETURN=0) RETURN=-1_"^"_ERROR "RTN","EAS1071Q",162,0) ; "RTN","EAS1071Q",163,0) EDPEXIT Q RETURN "RTN","EAS1071Q",164,0) ; "RTN","EASCM") 0^5^B80510854^n/a "RTN","EASCM",1,0) EASCM ;ALB/PJH - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 9/4/07 4:46pm "RTN","EASCM",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**; 15-MAR-01;Build 18 "RTN","EASCM",3,0) ; "RTN","EASCM",4,0) ;CLONED FROM IVMCM (ESR EVENT DRIVER) "RTN","EASCM",5,0) ; "RTN","EASCM",6,0) ORF ; Handler for ORF type HL7 messages received from HEC "RTN","EASCM",7,0) ; "RTN","EASCM",8,0) ; Make sure POSTMASTER DUZ instead of DUZ of Person who "RTN","EASCM",9,0) ; started Incoming Logical Link. "RTN","EASCM",10,0) S DUZ=.5 "RTN","EASCM",11,0) N CNT,IVMRTN,SEGCNT "RTN","EASCM",12,0) S IVMRTN="IVMCMX" ;USE "IVMCMX" BECAUSE "IVMCM" ALREADY USED "RTN","EASCM",13,0) K ^TMP($J,IVMRTN),DIC "RTN","EASCM",14,0) S (DGMSGF,DGMTMSG)=1 ; HL7 rtn. Don't need DG interative messages. "RTN","EASCM",15,0) S HLECH=HL("ECH"),HLQ=HL("Q"),HLMID=HL("MID") "RTN","EASCM",16,0) K %,%H,%I D NOW^%DTC S HLDT=% "RTN","EASCM",17,0) F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","EASCM",18,0) . S CNT=0 "RTN","EASCM",19,0) . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE "RTN","EASCM",20,0) . F S CNT=$O(HLNODE(CNT)) Q:'CNT D "RTN","EASCM",21,0) . . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) "RTN","EASCM",22,0) S HLDA=HLMTIEN "RTN","EASCM",23,0) ; "RTN","EASCM",24,0) N SEG,EVENT,MSGID "RTN","EASCM",25,0) S:'$D(HLEVN) HLEVN=0 "RTN","EASCM",26,0) D NXTSEG^DGENUPL(HLDA,0,.SEG) "RTN","EASCM",27,0) Q:(SEG("TYPE")'="MSH") ;would not have reached here if this happened! "RTN","EASCM",28,0) S EVENT=$P(SEG(9),$E(HLECH),2) "RTN","EASCM",29,0) ; "RTN","EASCM",30,0) ; INITIALIZE HL7 VARIABLES "RTN","EASCM",31,0) S HLEID="EAS ESR "_$P($$SITE^VASITE,"^",3)_" ORF-"_EVENT_" SERVER" "RTN","EASCM",32,0) S HLEID=$O(^ORD(101,"B",HLEID,0)) "RTN","EASCM",33,0) D INIT^HLFNC2(HLEID,.HL) "RTN","EASCM",34,0) S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) "RTN","EASCM",35,0) ; "RTN","EASCM",36,0) ; Handle means test signature ORF (Z06) event "RTN","EASCM",37,0) I EVENT="Z06" D ORF^IVMPREC7 "RTN","EASCM",38,0) ; "RTN","EASCM",39,0) ; Handle income test ORF (Z10) event "RTN","EASCM",40,0) I EVENT="Z10" D Z10 "RTN","EASCM",41,0) ; "RTN","EASCM",42,0) ; Handle enrollment/elig. ORF (Z11) event "RTN","EASCM",43,0) I EVENT="Z11" D "RTN","EASCM",44,0) .S MSGID=SEG(10) "RTN","EASCM",45,0) .D ORFZ11^DGENUPL(HLDA,MSGID) "RTN","EASCM",46,0) ; "RTN","EASCM",47,0) K ^TMP($J,IVMRTN) "RTN","EASCM",48,0) Q "RTN","EASCM",49,0) ; "RTN","EASCM",50,0) ; "RTN","EASCM",51,0) Z10 ; Entry point for receipt of ORF~Z10 transmission "RTN","EASCM",52,0) ; The Income Test (Z10) transmission has the following format: "RTN","EASCM",53,0) ; "RTN","EASCM",54,0) ; BHS ORF msgs do not include batch header or trailer. "RTN","EASCM",55,0) ; {MSH "RTN","EASCM",56,0) ; PID They will include the sequence: MSA "RTN","EASCM",57,0) ; ZIC QRD "RTN","EASCM",58,0) ; ZIR QRF "RTN","EASCM",59,0) ; {ZDP These segments will follow the MSH segment. "RTN","EASCM",60,0) ; ZIC "RTN","EASCM",61,0) ; ZIR "RTN","EASCM",62,0) ; } "RTN","EASCM",63,0) ; {ZDP} Inactive Dependent Spouse Entries "RTN","EASCM",64,0) ; {ZDP} Inactive Dependent Child Entries "RTN","EASCM",65,0) ; {ZMT "RTN","EASCM",66,0) ; } "RTN","EASCM",67,0) ; ZBT "RTN","EASCM",68,0) ; } "RTN","EASCM",69,0) ; BTS "RTN","EASCM",70,0) ; "RTN","EASCM",71,0) S IVMORF=1 ; set ORF msg flag "RTN","EASCM",72,0) S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 ; init vars "RTN","EASCM",73,0) ; "RTN","EASCM",74,0) ORU ; Entry point for receipt of ORU~Z10 trans (called by IVMPREC2) "RTN","EASCM",75,0) S IVMTYPE=5,IVMZ10F=1 "RTN","EASCM",76,0) ; "RTN","EASCM",77,0) ; - loop through the msg in (#772 file), and process (PROC) msgs "RTN","EASCM",78,0) S IVMDA=0 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D PROC Q:'IVMDA "RTN","EASCM",79,0) ; "RTN","EASCM",80,0) ; - if ORF msg flag, update the Query Tran Log and send ACK "RTN","EASCM",81,0) I $G(IVMORF) D "RTN","EASCM",82,0) .I $G(DFN),$D(IVMMCI) D "RTN","EASCM",83,0) ..N IVMCR "RTN","EASCM",84,0) ..S IVMCR=$P("1^2^3^7^5^6^4","^",IVMTYPE) ;map reason to test type "RTN","EASCM",85,0) ..D FIND^IVMCQ2(DFN,IVMMCI,HLDT,$S($D(HLERR):5,1:IVMCR),1) "RTN","EASCM",86,0) .;D ACK^IVMPREC:'$D(HLERR) "RTN","EASCM",87,0) .;N HLRESLTA,HLP "RTN","EASCM",88,0) .;D GENACK^HLMA1(HLEID,HLMTIEN,HLEIDS,"LM",1,.HLRESLTA,"",.HLP) "RTN","EASCM",89,0) ; "RTN","EASCM",90,0) ; - if tests are uploaded, generate notification msg "RTN","EASCM",91,0) I $D(^TMP($J,"IVMBULL")) D ^IVMCMB "RTN","EASCM",92,0) ; "RTN","EASCM",93,0) ENQ ; "RTN","EASCM",94,0) K IVMDA,IVMORF,IVMSEG,IVMFLGC,IVMTYPE,IVMMTIEN,IVMMTDT,IVMDGBT,IVMMCI "RTN","EASCM",95,0) K ^TMP($J,"IVMCM"),^("IVMBULL"),DGMSGF,DGADDF,IVMCPAY,IVMBULL,DFN "RTN","EASCM",96,0) K DGMTMSG,IVMZ10F "RTN","EASCM",97,0) Q "RTN","EASCM",98,0) ; "RTN","EASCM",99,0) PROC ; Process each HL7 message from (#772) file "RTN","EASCM",100,0) ; "RTN","EASCM",101,0) N IVMFUTR,TMSTAMP,SOURCE,NODE,HSDATE,IVMZ10,DGMTP,DGMTACT,DGMTI,DGMTA "RTN","EASCM",102,0) S DGMTACT="ADD" "RTN","EASCM",103,0) D PRIOR^DGMTEVT "RTN","EASCM",104,0) S IVMZ10="UPLOAD IN PROGRESS" "RTN","EASCM",105,0) S IVMFUTR=0 ;this flag will indicate whether or not a test with a future date is being uploaded "RTN","EASCM",106,0) S IVMMTIEN=0 "RTN","EASCM",107,0) ; "RTN","EASCM",108,0) S MSGID=$P(IVMSEG,HLFS,10) ; msg control id for ACK's "RTN","EASCM",109,0) ; - check if DCD messaging is enabled "RTN","EASCM",110,0) I '$$DCDON^IVMUPAR1() D PROB^IVMCMC("Facility has DCD messaging disabled") Q "RTN","EASCM",111,0) ; "RTN","EASCM",112,0) ; - check HL7 msg structure for errors "RTN","EASCM",113,0) K HLERR,^TMP($J,"IVMCM") "RTN","EASCM",114,0) D ^IVMCMC I $D(HLERR) K:HLERR="" HLERR Q "RTN","EASCM",115,0) ; "RTN","EASCM",116,0) ; Determine type of test/transmission "RTN","EASCM",117,0) S IVMTYPE=0 "RTN","EASCM",118,0) ; "RTN","EASCM",119,0) ; - was a means test sent? "RTN","EASCM",120,0) I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2) S IVMTYPE=1 ; MT trans "RTN","EASCM",121,0) ; "RTN","EASCM",122,0) ; - if MT and CT transmitted, error - pt can't have both unless "RTN","EASCM",123,0) ; one is a deletion, but HEC not currently handling that situation "RTN","EASCM",124,0) I IVMTYPE,$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) D PROB^IVMCMC("Patient can not have both a Means Test and Copay Test") Q "RTN","EASCM",125,0) I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) S IVMTYPE=2 ; CT trans "RTN","EASCM",126,0) ; "RTN","EASCM",127,0) ; - if no MT or CT or LTC then Income Screening "RTN","EASCM",128,0) I 'IVMTYPE,'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) S IVMTYPE=3 ; IS trans "RTN","EASCM",129,0) ; "RTN","EASCM",130,0) ;send an eligibility query if no eligibility code "RTN","EASCM",131,0) I '$$ELIG^IVMCUF1(DFN),'$$PENDING^DGENQRY(DFN) I $$SEND^DGENQRY1(DFN) "RTN","EASCM",132,0) ; "RTN","EASCM",133,0) ; obtain locks used to sychronize upload with local income test options "RTN","EASCM",134,0) D GETLOCKS^IVMCUPL(DFN) "RTN","EASCM",135,0) ; "RTN","EASCM",136,0) ; "RTN","EASCM",137,0) MT ; If transmission is a Means Test "RTN","EASCM",138,0) N NODE0,RET,CODE,DATA,MTSIG,MTSIGDT "RTN","EASCM",139,0) S HLQ=$G(HL("Q")) "RTN","EASCM",140,0) S:HLQ="" HLQ="""""" "RTN","EASCM",141,0) I IVMTYPE=1 D I $D(HLERR) G PROCQ "RTN","EASCM",142,0) .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2)) "RTN","EASCM",143,0) .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,25)) "RTN","EASCM",144,0) .S HSDATE=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,24)) "RTN","EASCM",145,0) .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22) "RTN","EASCM",146,0) .S MTSIG=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,27) "RTN","EASCM",147,0) .S MTSIGDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,15)) "RTN","EASCM",148,0) .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1) "RTN","EASCM",149,0) .Q:$$UPDMTSIG^IVMCMF(+IVMLAST,TMSTAMP,MTSIG,MTSIGDT) "RTN","EASCM",150,0) .I $$Z06MT^EASPTRN1(+IVMLAST) Q "RTN","EASCM",151,0) .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient" "RTN","EASCM",152,0) .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D "RTN","EASCM",153,0) ..N CATCZMT S CATCZMT=$G(^TMP($J,"IVMCM","ZMT1")) "RTN","EASCM",154,0) ..S CATC=$$CATC^IVMUFNC5(CATCZMT) "RTN","EASCM",155,0) ..I '+$G(CATC) S ERRMSG="Only Means Tests in current/previous income years are valid (not effective)" "RTN","EASCM",156,0) .I $G(ERRMSG)'="" D PROB^IVMCMC(ERRMSG) K ERRMSG,CATC Q "RTN","EASCM",157,0) .; "RTN","EASCM",158,0) .; - perform edit checks and file MT "RTN","EASCM",159,0) .D CHKDT "RTN","EASCM",160,0) .;deletion indicator sent? "RTN","EASCM",161,0) .I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,3)=HLQ D Q "RTN","EASCM",162,0) ..D "RTN","EASCM",163,0) ...;if there is a future test for that income year, delete that "RTN","EASCM",164,0) ...N IEN,DATA,IVMPAT "RTN","EASCM",165,0) ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1,.IVMPAT) "RTN","EASCM",166,0) ...I IEN S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) "RTN","EASCM",167,0) ...I IEN,$D(^DGMT(408.31,IEN,0)) D "RTN","EASCM",168,0) ....S IVMMTIEN=IEN "RTN","EASCM",169,0) ....S IVMFUTR=1 "RTN","EASCM",170,0) ...E D "RTN","EASCM",171,0) ....S IVMFUTR=0 "RTN","EASCM",172,0) ..Q:('IVMMTIEN) "RTN","EASCM",173,0) ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) "RTN","EASCM",174,0) ..I $$EN^IVMCMD(IVMMTIEN) D "RTN","EASCM",175,0) ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) "RTN","EASCM",176,0) ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") "RTN","EASCM",177,0) ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) "RTN","EASCM",178,0) .; "RTN","EASCM",179,0) .;check timestamp - if matches current primary test and hardship matches, then this is a duplicate and does not need to be uploaded "RTN","EASCM",180,0) .I TMSTAMP D "RTN","EASCM",181,0) ..S NODE="" "RTN","EASCM",182,0) ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1) "RTN","EASCM",183,0) ..Q:'IVMMTIEN "RTN","EASCM",184,0) ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) "RTN","EASCM",185,0) .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) "RTN","EASCM",186,0) .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5),(HSDATE=$P(NODE,"^")) Q "RTN","EASCM",187,0) .; "RTN","EASCM",188,0) .D DELTYPE^IVMCMD(DFN,IVMMTDT,2) "RTN","EASCM",189,0) .D EN^IVMCM1 "RTN","EASCM",190,0) ; "RTN","EASCM",191,0) ; "RTN","EASCM",192,0) CT ; If transmission is a Copay Test "RTN","EASCM",193,0) N NODE0,RET,CODE,DATA "RTN","EASCM",194,0) I IVMTYPE=2 D I $D(HLERR) G PROCQ "RTN","EASCM",195,0) .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2)) "RTN","EASCM",196,0) .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,25)) "RTN","EASCM",197,0) .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,22) "RTN","EASCM",198,0) .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,2) "RTN","EASCM",199,0) .S IVMCPAY=$$RXST^IBARXEU(DFN) "RTN","EASCM",200,0) .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D PROB^IVMCMC("Only Copay Tests in the current/previous income years are valid. (Not effective)") Q "RTN","EASCM",201,0) .; - perform edit checks and file CT "RTN","EASCM",202,0) .D CHKDT "RTN","EASCM",203,0) .;deletion indicator sent? "RTN","EASCM",204,0) .I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,3)=HLQ D Q "RTN","EASCM",205,0) ..D "RTN","EASCM",206,0) ...;if there is a future test for that income year, delete that "RTN","EASCM",207,0) ...N IEN,DATA,IVMPAT "RTN","EASCM",208,0) ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2,.IVMPAT) "RTN","EASCM",209,0) ...I IEN S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA) "RTN","EASCM",210,0) ...I IEN,$D(^DGMT(408.31,IEN,0)) D "RTN","EASCM",211,0) ....S IVMMTIEN=IEN "RTN","EASCM",212,0) ....S IVMFUTR=1 "RTN","EASCM",213,0) ...E D "RTN","EASCM",214,0) ....S IVMFUTR=0 "RTN","EASCM",215,0) ..Q:('IVMMTIEN) "RTN","EASCM",216,0) ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) "RTN","EASCM",217,0) ..I $$EN^IVMCMD(IVMMTIEN) D "RTN","EASCM",218,0) ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE) "RTN","EASCM",219,0) ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"") "RTN","EASCM",220,0) ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE) "RTN","EASCM",221,0) .; "RTN","EASCM",222,0) .;check timestamp - if matches current primary test, then this is a duplicate and does not need to be uploaded "RTN","EASCM",223,0) .I TMSTAMP D "RTN","EASCM",224,0) ..S NODE="" "RTN","EASCM",225,0) ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2) "RTN","EASCM",226,0) ..Q:'IVMMTIEN "RTN","EASCM",227,0) ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2)) "RTN","EASCM",228,0) .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0)) "RTN","EASCM",229,0) .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5) Q "RTN","EASCM",230,0) .; "RTN","EASCM",231,0) .D DELTYPE^IVMCMD(DFN,IVMMTDT,1) "RTN","EASCM",232,0) .D EN^IVMCM1 "RTN","EASCM",233,0) ; "RTN","EASCM",234,0) IS ; - If transmission is income screening info only then do not process "RTN","EASCM",235,0) ; - outside of the scope of MTS "RTN","EASCM",236,0) I IVMTYPE=3 S IVMMTDT=0 "RTN","EASCM",237,0) ; "RTN","EASCM",238,0) LTC ; If transmission contains a Long Term Care Test (TYPE 4 TEST) "RTN","EASCM",239,0) I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) D LTC^IVMCM1 "RTN","EASCM",240,0) ; "RTN","EASCM",241,0) PROCQ ; "RTN","EASCM",242,0) ; release locks used to sychronize upload with local income test options "RTN","EASCM",243,0) D RELLOCKS^IVMCUPL(DFN) "RTN","EASCM",244,0) Q "RTN","EASCM",245,0) ; "RTN","EASCM",246,0) CHKDT ; check date of income test being uploaded "RTN","EASCM",247,0) ; Is it a future date? If so, set IVMFUTR=1 "RTN","EASCM",248,0) ; "RTN","EASCM",249,0) ; IVMMTIEN is the IEN of current primary test for the year "RTN","EASCM",250,0) ; "RTN","EASCM",251,0) I $E($P(IVMLAST,"^",2),1,3)=$E(IVMMTDT,1,3) S IVMMTIEN=+IVMLAST "RTN","EASCM",252,0) I IVMMTDT>DT S IVMFUTR=1 "RTN","EASCM",253,0) Q "RTN","EASCM",254,0) FUTURE(DFN,YEAR,TYPE,IVMPAT) ; "RTN","EASCM",255,0) ;Returns the ien of the future test, if there is one "RTN","EASCM",256,0) ;Inputs: DFN "RTN","EASCM",257,0) ; YEAR - income year "RTN","EASCM",258,0) ; TYPE - type of test "RTN","EASCM",259,0) ;Output: "RTN","EASCM",260,0) ; function value - ien of future means test, if there is one, "" otherwise "RTN","EASCM",261,0) ; IVMPAT - Pointer to the IVM Patient file for the income year if there is an entry (pass by reference) "RTN","EASCM",262,0) ; "RTN","EASCM",263,0) N RET "RTN","EASCM",264,0) S RET="" "RTN","EASCM",265,0) S IVMPAT=$$FIND^IVMPLOG(DFN,YEAR) "RTN","EASCM",266,0) I IVMPAT S RET=$P($G(^IVM(301.5,IVMPAT,0)),"^",$S(TYPE=1:6,1:7)) "RTN","EASCM",267,0) Q RET "RTN","EASEGT2") 0^6^B33652656^n/a "RTN","EASEGT2",1,0) EASEGT2 ;ALB/PJH - PROCESS INCOMING MFN TYPE HL7 MSGS ; 11/27/07 3:03pm "RTN","EASEGT2",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EASEGT2",3,0) ; "RTN","EASEGT2",4,0) ; CLONED FROM DGENEGT2 (ESR EVENT DRIVER) "RTN","EASEGT2",5,0) ; "RTN","EASEGT2",6,0) MFN ; Description: This entry point is the handler for incoming MFN type "RTN","EASEGT2",7,0) ; HL7 messages. This entry point is called from the PROCESSING ROUTINE "RTN","EASEGT2",8,0) ; field of the HL7 MESSAGE (multiple) field of the #771 file entry. "RTN","EASEGT2",9,0) ; "RTN","EASEGT2",10,0) ; Input: "RTN","EASEGT2",11,0) ; The following HL7 variables are set when the DHCP Application "RTN","EASEGT2",12,0) ; processing routine is invoked: "RTN","EASEGT2",13,0) ; HLDA - the internal entry number for the entry created in "RTN","EASEGT2",14,0) ; file #772. "RTN","EASEGT2",15,0) ; HLDAN - the name of the receiving application from the HL7 DHCP "RTN","EASEGT2",16,0) ; APPLICATION #771 file "RTN","EASEGT2",17,0) ; HLDAP - ien of the receiving application from the HL7 DHCP "RTN","EASEGT2",18,0) ; APPLICATION #771 file "RTN","EASEGT2",19,0) ; HLDT - date/time message was received in internal fileman format "RTN","EASEGT2",20,0) ; HLDT1 - date/time message was received in HL7 format "RTN","EASEGT2",21,0) ; HLECH - HL7 Encoding Characters from the 'EC' node of file #771 "RTN","EASEGT2",22,0) ; HLFS - HL7 Field Separator from the 'FS' node of file #771 "RTN","EASEGT2",23,0) ; HLMID - HL7 message control ID of the message received "RTN","EASEGT2",24,0) ; HLMTN - 3-7 character message type of the message received "RTN","EASEGT2",25,0) ; HLNDAP - Non-DHCP Application Pointer from file #770 "RTN","EASEGT2",26,0) ; HLNDAP0 - Zero node from file #770 corresponding to HLNDAP "RTN","EASEGT2",27,0) ; HLQ - Double quotes ("") for use in building HL7 segments "RTN","EASEGT2",28,0) ; HLVER - HL7 version number of the HL7 protocol that was used to "RTN","EASEGT2",29,0) ; build the message received "RTN","EASEGT2",30,0) ; "RTN","EASEGT2",31,0) ; other HL7 variables used: "RTN","EASEGT2",32,0) ; HLEVN - number of HL7 events included in the HL7 message "RTN","EASEGT2",33,0) ; HLSDT - a flag that indicates that the data to be sent is "RTN","EASEGT2",34,0) ; stored in the ^TMP("HLS") global array. "RTN","EASEGT2",35,0) ; HLTRANS - existence of this variable indicates that the incoming "RTN","EASEGT2",36,0) ; HL7 message is being processed by the HLSERV routine and "RTN","EASEGT2",37,0) ; VA MailMan is the lowere level protocol being used. "RTN","EASEGT2",38,0) ; "RTN","EASEGT2",39,0) ; "RTN","EASEGT2",40,0) N EVENT,MSGID,SEG "RTN","EASEGT2",41,0) N CNT,HL,IVMRTN,SEGCNT "RTN","EASEGT2",42,0) ; "RTN","EASEGT2",43,0) ; SET UP WORK GLOBAL WITH INCOMING MESSAGE "RTN","EASEGT2",44,0) S IVMRTN="DGENEGT2" "RTN","EASEGT2",45,0) K ^TMP($J,IVMRTN) "RTN","EASEGT2",46,0) F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","EASEGT2",47,0) .S CNT=0 "RTN","EASEGT2",48,0) .S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE "RTN","EASEGT2",49,0) .F S CNT=$O(HLNODE(CNT)) Q:'CNT D "RTN","EASEGT2",50,0) ..S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) "RTN","EASEGT2",51,0) S HLDA=HLMTIEN "RTN","EASEGT2",52,0) ; "RTN","EASEGT2",53,0) ; INITIALIZE HL7 VARIABLES "RTN","EASEGT2",54,0) S HLEID="EAS ESR "_$P($$SITE^VASITE,"^",3)_" MFN-ZEG SERVER" "RTN","EASEGT2",55,0) S HLEID=$O(^ORD(101,"B",HLEID,0)) "RTN","EASEGT2",56,0) D INIT^HLFNC2(HLEID,.HL) "RTN","EASEGT2",57,0) S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) "RTN","EASEGT2",58,0) ; "RTN","EASEGT2",59,0) D NXTSEG^DGENUPL(HLDA,0,.SEG) "RTN","EASEGT2",60,0) Q:(SEG("TYPE")'="MSH") "RTN","EASEGT2",61,0) S EVENT=$P(SEG(9),$E(HLECH),2) "RTN","EASEGT2",62,0) ; "RTN","EASEGT2",63,0) I EVENT="ZEG" D "RTN","EASEGT2",64,0) .S MSGID=SEG(10) "RTN","EASEGT2",65,0) .D EGT(HLDA,MSGID) "RTN","EASEGT2",66,0) ; "RTN","EASEGT2",67,0) K ^TMP($J,IVMRTN) "RTN","EASEGT2",68,0) Q "RTN","EASEGT2",69,0) ; "RTN","EASEGT2",70,0) ; "RTN","EASEGT2",71,0) EGT(MSGIEN,MSGID) ; "RTN","EASEGT2",72,0) ; Description: This procedure is used to process an MFN~ZEG message. "RTN","EASEGT2",73,0) ; It uploads the enrollment group threshold (EGT) data. An HL7 "RTN","EASEGT2",74,0) ; Master File Acknowledgement (MFK) will be returned. "RTN","EASEGT2",75,0) ; "RTN","EASEGT2",76,0) ; Input: "RTN","EASEGT2",77,0) ; MSGIEN - the internal entry number of the HL7 message in the "RTN","EASEGT2",78,0) ; HL7 MESSAGE TEXT (#772) file "RTN","EASEGT2",79,0) ; MSGID - the message control id from the MSH segment "RTN","EASEGT2",80,0) ; "RTN","EASEGT2",81,0) ; Output: None "RTN","EASEGT2",82,0) ; "RTN","EASEGT2",83,0) N CURLINE,ERRCOUNT,SEG "RTN","EASEGT2",84,0) ; "RTN","EASEGT2",85,0) ; initialize HL7 variables "RTN","EASEGT2",86,0) S HLSDT="IVMQ" ; subscript in ^TMP( global for MFK message "RTN","EASEGT2",87,0) K ^TMP("HLA",$J) "RTN","EASEGT2",88,0) ; "RTN","EASEGT2",89,0) ; init variables "RTN","EASEGT2",90,0) S ERRCOUNT=0 ; used to indicate error "RTN","EASEGT2",91,0) S CURLINE=1 "RTN","EASEGT2",92,0) ; "RTN","EASEGT2",93,0) ; process master file notification msg "RTN","EASEGT2",94,0) D MFNZEG(MSGIEN,MSGID,.CURLINE,.ERRCOUNT) "RTN","EASEGT2",95,0) ; "RTN","EASEGT2",96,0) ; transmit master file application acknowledgment (MFK) "RTN","EASEGT2",97,0) S HLEVN=$S(+$G(ERRCOUNT):+$G(ERRCOUNT),1:1) "RTN","EASEGT2",98,0) S HLARYTYP="GM",HLFORMAT=1 "RTN","EASEGT2",99,0) D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESLTA) "RTN","EASEGT2",100,0) ; "RTN","EASEGT2",101,0) Q "RTN","EASEGT2",102,0) ; "RTN","EASEGT2",103,0) ; "RTN","EASEGT2",104,0) MFNZEG(MSGIEN,MSGID,CURLINE,ERRCOUNT) ; "RTN","EASEGT2",105,0) ; Description: This procedure is used to process a MFN~ZEG msg. "RTN","EASEGT2",106,0) ; "RTN","EASEGT2",107,0) ; Input: "RTN","EASEGT2",108,0) ; MSGIEN - the internal entry number of the HL7 message in the "RTN","EASEGT2",109,0) ; HL7 MESSAGE TEXT (#772) file "RTN","EASEGT2",110,0) ; MSGID - message control id of HL7 msg in the MSH segment "RTN","EASEGT2",111,0) ; CURLINE - the subscript of the MSH segment of the current message "RTN","EASEGT2",112,0) ; (pass by reference) "RTN","EASEGT2",113,0) ; "RTN","EASEGT2",114,0) ; Output: "RTN","EASEGT2",115,0) ; CURLINE - upon leaving the procedure this parameter should be set to "RTN","EASEGT2",116,0) ; the end of the current message. (pass by reference) "RTN","EASEGT2",117,0) ; ERRCOUNT - set if error encountered (pass by reference) "RTN","EASEGT2",118,0) ; "RTN","EASEGT2",119,0) N DGEGT,DGMFI,DGMFE,ERRMSG,OLDEGT "RTN","EASEGT2",120,0) ; "RTN","EASEGT2",121,0) ; drops out of DO block on error "RTN","EASEGT2",122,0) D "RTN","EASEGT2",123,0) .; parse the message "RTN","EASEGT2",124,0) .Q:'$$PARSE(MSGIEN,MSGID,.CURLINE,.ERRCOUNT,.DGEGT,.DGMFI,.DGMFE) "RTN","EASEGT2",125,0) .; "RTN","EASEGT2",126,0) .; get the current EGT record if it exists "RTN","EASEGT2",127,0) .I $$GET^DGENEGT($$FINDCUR^DGENEGT(),.OLDEGT) "RTN","EASEGT2",128,0) .; "RTN","EASEGT2",129,0) .; add assumed values to the EGT record containing the update "RTN","EASEGT2",130,0) .S DGEGT("ENTDATE")=$$NOW^XLFDT ; set to currnet date/time "RTN","EASEGT2",131,0) .S DGEGT("SOURCE")=1 ; set source of EGT to 'HEC' "RTN","EASEGT2",132,0) .; "RTN","EASEGT2",133,0) .; perform field validation checks on the EGT record "RTN","EASEGT2",134,0) .I '$$VALID^DGENEGT(.DGEGT,.ERRMSG) D Q "RTN","EASEGT2",135,0) ..D ADDERROR(MSGID,ERRMSG,.ERRCOUNT,.DGMFI,.DGMFE) "RTN","EASEGT2",136,0) .; "RTN","EASEGT2",137,0) .; store enrollment group threshold (EGT) record "RTN","EASEGT2",138,0) .D UPLDEGT^DGENEGT3(.DGEGT) "RTN","EASEGT2",139,0) .; "RTN","EASEGT2",140,0) .; if no error encountered, create an 'AA' MFK "RTN","EASEGT2",141,0) .D ACCEPT(MSGID,.DGMFI,.DGMFE) "RTN","EASEGT2",142,0) .; "RTN","EASEGT2",143,0) .; send local EGT notification msg "RTN","EASEGT2",144,0) .D NOTIFY^DGENEGT1(.DGEGT,.OLDEGT) "RTN","EASEGT2",145,0) ; "RTN","EASEGT2",146,0) Q "RTN","EASEGT2",147,0) ; "RTN","EASEGT2",148,0) ; "RTN","EASEGT2",149,0) PARSE(MSGIEN,MSGID,CURLINE,ERRCOUNT,DGEGT,DGMFI,DGMFE) ; "RTN","EASEGT2",150,0) ; Description: This function is used to parse the HL7 segments of the message. "RTN","EASEGT2",151,0) ; "RTN","EASEGT2",152,0) ; Input: "RTN","EASEGT2",153,0) ; MSGIEN - the internal entry number of the HL7 message in the "RTN","EASEGT2",154,0) ; HL7 MESSAGE TEXT (#772) file "RTN","EASEGT2",155,0) ; MSGID - message control id of HL7 msg in the MSH segment "RTN","EASEGT2",156,0) ; CURLINE - the subscript of the MSH segment of the current message "RTN","EASEGT2",157,0) ; (pass by reference) "RTN","EASEGT2",158,0) ; "RTN","EASEGT2",159,0) ; Output: "RTN","EASEGT2",160,0) ; Function Value: Returns 1 on success, 0 on failure "RTN","EASEGT2",161,0) ; DGEGT - array containing the EGT record (pass by reference) "RTN","EASEGT2",162,0) ; DGMFI - array containing fields of MFI segment needed for "RTN","EASEGT2",163,0) ; MFK (pass by reference) "RTN","EASEGT2",164,0) ; DGMFE - array containing fields of MFE segment needed for "RTN","EASEGT2",165,0) ; MFK (pass by reference) "RTN","EASEGT2",166,0) ; ERRCOUNT - set if error encountered (pass by reference) "RTN","EASEGT2",167,0) ; "RTN","EASEGT2",168,0) N ERROR,SEG "RTN","EASEGT2",169,0) S ERROR=0 "RTN","EASEGT2",170,0) ; "RTN","EASEGT2",171,0) K DGEGT,DGMFI,DGMFE "RTN","EASEGT2",172,0) S (DGMFI,DGMFE)="" "RTN","EASEGT2",173,0) ; "RTN","EASEGT2",174,0) F SEG="MFI","MFE","ZEG" D Q:ERROR "RTN","EASEGT2",175,0) .D NXTSEG^DGENUPL(MSGIEN,.CURLINE,.SEG) "RTN","EASEGT2",176,0) .I SEG("TYPE")=SEG D "RTN","EASEGT2",177,0) ..D @(SEG_"^DGENEGT3") "RTN","EASEGT2",178,0) .E D "RTN","EASEGT2",179,0) ..D ADDERROR(MSGID,SEG_" SEGMENT MISSING",.ERRCOUNT,.DGMFI,.DGMFE) "RTN","EASEGT2",180,0) ..S ERROR=1 "RTN","EASEGT2",181,0) ; "RTN","EASEGT2",182,0) Q $S(ERROR:0,1:1) "RTN","EASEGT2",183,0) ; "RTN","EASEGT2",184,0) ; "RTN","EASEGT2",185,0) ADDERROR(MSGID,ERRMSG,ERRCOUNT,DGMFI,DGMFE) ; "RTN","EASEGT2",186,0) ; Description - This procedure writes an MFK - Application Error (AE) "RTN","EASEGT2",187,0) ; to the global that is used in the transmission of the 'MFK' msg. "RTN","EASEGT2",188,0) ; "RTN","EASEGT2",189,0) ; Inputs: "RTN","EASEGT2",190,0) ; MSGID - message control id of HL7 msg in the MSH segment "RTN","EASEGT2",191,0) ; ERRMSG - the error msg text "RTN","EASEGT2",192,0) ; ERRCOUNT - count of errors written (pass by reference) "RTN","EASEGT2",193,0) ; DGMFI - array containing fields of MFI segment received, needed "RTN","EASEGT2",194,0) ; for MFK (pass by reference) "RTN","EASEGT2",195,0) ; DGMFE - array containing fields of MFI segment received, needed "RTN","EASEGT2",196,0) ; for MFK (pass by reference) "RTN","EASEGT2",197,0) ; "RTN","EASEGT2",198,0) ; Outputs: "RTN","EASEGT2",199,0) ; ^TMP("HLS",$J,I) - global array containing all segments of "RTN","EASEGT2",200,0) ; the HL7 message that the receiving application wishes to send "RTN","EASEGT2",201,0) ; as response. The HLSDT variable is a flag that indicates that "RTN","EASEGT2",202,0) ; the data to be sent is stored in in the ^TMP("HLS") global "RTN","EASEGT2",203,0) ; array. The variable (I) is sequential number. "RTN","EASEGT2",204,0) ; "RTN","EASEGT2",205,0) S ERRCOUNT=+$G(ERRCOUNT) "RTN","EASEGT2",206,0) ; "RTN","EASEGT2",207,0) ; MSA segment "RTN","EASEGT2",208,0) S ^TMP("HLA",$J,(ERRCOUNT*2)+1)="MSA"_HLFS_"AE"_HLFS_MSGID_HLFS_ERRMSG "RTN","EASEGT2",209,0) ; "RTN","EASEGT2",210,0) ; MFI segment "RTN","EASEGT2",211,0) S ^TMP("HLA",$J,(ERRCOUNT*2)+2)="MFI"_HLFS_$G(DGMFI("MASTERID"))_HLFS_HLFS_$G(DGMFI("EVENT")) "RTN","EASEGT2",212,0) ; "RTN","EASEGT2",213,0) ; MFA segment "RTN","EASEGT2",214,0) S ^TMP("HLA",$J,(ERRCOUNT*2)+3)="MFA"_HLFS_$G(DGMFE("RECEVNT"))_HLFS_$G(DGMFE("CNTRLNUM"))_HLFS_HLFS_"U"_HLFS_$G(DGMFE("PRIMKEY")) "RTN","EASEGT2",215,0) S ERRCOUNT=ERRCOUNT+1 "RTN","EASEGT2",216,0) Q "RTN","EASEGT2",217,0) ; "RTN","EASEGT2",218,0) ; "RTN","EASEGT2",219,0) ACCEPT(MSGID,DGMFI,DGMFE) ; "RTN","EASEGT2",220,0) ; Description - This procedure writes an MFK - Application Accept (AA) "RTN","EASEGT2",221,0) ; to the global that is used in the transmission of the 'MFK' msg. "RTN","EASEGT2",222,0) ; "RTN","EASEGT2",223,0) ; Inputs: "RTN","EASEGT2",224,0) ; MSGID - message control id of HL7 msg in the MSH segment "RTN","EASEGT2",225,0) ; DGMFI - array containing fields of MFI segment received, needed "RTN","EASEGT2",226,0) ; for MFK (pass by reference) "RTN","EASEGT2",227,0) ; DGMFE - array containing fields of MFI segment received, needed "RTN","EASEGT2",228,0) ; for MFK (pass by reference) "RTN","EASEGT2",229,0) ; "RTN","EASEGT2",230,0) ; Outputs: "RTN","EASEGT2",231,0) ; ^TMP("HLS",$J,HLSDT,I) - global array containing all segments of "RTN","EASEGT2",232,0) ; the HL7 message that the receiving application wishes to send "RTN","EASEGT2",233,0) ; as response. The HLSDT variable is a flag that indicates that "RTN","EASEGT2",234,0) ; the data to be sent is stored in in the ^TMP("HLS") global "RTN","EASEGT2",235,0) ; array. The variable (I) is sequential number. "RTN","EASEGT2",236,0) ; "RTN","EASEGT2",237,0) N DGCOUNT "RTN","EASEGT2",238,0) S DGCOUNT=1 ; sequential number used as array subscript "RTN","EASEGT2",239,0) ; "RTN","EASEGT2",240,0) ; MSA segment "RTN","EASEGT2",241,0) S DGCOUNT=DGCOUNT+1 "RTN","EASEGT2",242,0) S ^TMP("HLA",$J,DGCOUNT)="MSA"_HLFS_"AA"_HLFS_MSGID "RTN","EASEGT2",243,0) ; "RTN","EASEGT2",244,0) ; MFI segment "RTN","EASEGT2",245,0) S DGCOUNT=DGCOUNT+1 "RTN","EASEGT2",246,0) S ^TMP("HLA",$J,DGCOUNT)="MFI"_HLFS_$G(DGMFI("MASTERID"))_HLFS_HLFS_$G(DGMFI("EVENT")) "RTN","EASEGT2",247,0) ; "RTN","EASEGT2",248,0) ; MFA segment "RTN","EASEGT2",249,0) S DGCOUNT=DGCOUNT+1 "RTN","EASEGT2",250,0) S ^TMP("HLA",$J,DGCOUNT)="MFA"_HLFS_$G(DGMFE("RECEVNT"))_HLFS_$G(DGMFE("CNTRLNUM"))_HLFS_HLFS_"S"_HLFS_$G(DGMFE("PRIMKEY")) "RTN","EASEGT2",251,0) Q "RTN","EASPREC3") 0^7^B11323531^n/a "RTN","EASPREC3",1,0) EASPREC3 ;ALB/PJH - PROCESS INCOMING HL7 (QRY) MESSAGES ; 11/27/07 3:04pm "RTN","EASPREC3",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EASPREC3",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","EASPREC3",4,0) ; "RTN","EASPREC3",5,0) ; CLONED FROM IVMPREC2 (ESR EVENT DRIVER) "RTN","EASPREC3",6,0) ; "RTN","EASPREC3",7,0) ; This routine will process (ORU) HL7 messages received from the "RTN","EASPREC3",8,0) ; IVM center. Event type code indicating type of transmission is "RTN","EASPREC3",9,0) ; in the BHS segment. Routines based on type will be called to "RTN","EASPREC3",10,0) ; process these messages. For each batch an ACK will be sent to "RTN","EASPREC3",11,0) ; the IVM Center indicating errors found. If any errors are found "RTN","EASPREC3",12,0) ; a batch message with AE(indicating error(s)) is sent. If no errors "RTN","EASPREC3",13,0) ; only a MSH and MSA with AA(no errors) is sent. The following event "RTN","EASPREC3",14,0) ; type codes are processed in the following routines: "RTN","EASPREC3",15,0) ; "RTN","EASPREC3",16,0) ; EVENT CODE TRANSMISSION TYPE PROCESSING ROUTINE "RTN","EASPREC3",17,0) ; ============================================================== "RTN","EASPREC3",18,0) ; Z03 SSN TRANSMISSIONS IVMPREC5 "RTN","EASPREC3",19,0) ; Z04 INSURANCE TRANSMISSIONS IVMPREC3 "RTN","EASPREC3",20,0) ; Z05 DEMOGRAPHIC TRANSMISSIONS IVMPREC6 "RTN","EASPREC3",21,0) ; Z06 MEANS TEST TRANSMISSIONS IVMPREC7 "RTN","EASPREC3",22,0) ; Z08 CASE STATUS TRANSMISSIONS IVMPREC4 "RTN","EASPREC3",23,0) ; Z10 INCOME TEST TRANSMISSIONS IVMCM "RTN","EASPREC3",24,0) ; Z11 ENROLLMENT/ELIGIBILTY ORUZ11^DGENUPL "RTN","EASPREC3",25,0) ; "RTN","EASPREC3",26,0) ; "RTN","EASPREC3",27,0) ORU ; - Receive Observational Results Unsolicited Message "RTN","EASPREC3",28,0) ; "RTN","EASPREC3",29,0) N DIC,%,%H,%I D NOW^%DTC S HLDT=% "RTN","EASPREC3",30,0) K HLERR,IVMSEG1,IVMSEG2,IVMSEG3 "RTN","EASPREC3",31,0) S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 "RTN","EASPREC3",32,0) ; Make sure POSTMASTER DUZ instead of DUZ of Person who "RTN","EASPREC3",33,0) ; started Incoming Logical Link "RTN","EASPREC3",34,0) S DUZ=.5 "RTN","EASPREC3",35,0) ; "RTN","EASPREC3",36,0) ; - get incoming segment from HL7 (#772) file "RTN","EASPREC3",37,0) N IVMRTN,SEGCNT,CNT,STATION,HLEID,HLEIDS "RTN","EASPREC3",38,0) S IVMRTN="IVMPREC2" K ^TMP($J,IVMRTN),^TMP("HLA",$J),^TMP("HLS",$J) "RTN","EASPREC3",39,0) F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","EASPREC3",40,0) . S CNT=0 "RTN","EASPREC3",41,0) . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE "RTN","EASPREC3",42,0) . F S CNT=$O(HLNODE(CNT)) Q:'CNT S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) "RTN","EASPREC3",43,0) ; "RTN","EASPREC3",44,0) S HLDA=HLMTIEN "RTN","EASPREC3",45,0) S IVMSEG=$G(^TMP($J,IVMRTN,1,0)) I IVMSEG']"" G ORUQ "RTN","EASPREC3",46,0) ; "RTN","EASPREC3",47,0) ; - check for BHS "RTN","EASPREC3",48,0) I $E(IVMSEG,1,3)'="BHS" G ORUQ "RTN","EASPREC3",49,0) ; "RTN","EASPREC3",50,0) ; - get batch control id "RTN","EASPREC3",51,0) S HLFS=HL("FS") "RTN","EASPREC3",52,0) S HLECH=HL("ECH") "RTN","EASPREC3",53,0) S HLQ=$G(HL("HLQ")) S:HLQ="" HLQ="""""" "RTN","EASPREC3",54,0) S IVMHLMID=$P(IVMSEG,HLFS,11) "RTN","EASPREC3",55,0) S STATION=$P(IVMSEG,HLFS,6) "RTN","EASPREC3",56,0) ; "RTN","EASPREC3",57,0) ; - get event type code "RTN","EASPREC3",58,0) S IVMETC=$P($P(IVMSEG,HLFS,9),$E(HLECH),3) "RTN","EASPREC3",59,0) S IVMETC=$P(IVMETC,$E(HLECH,2),2) "RTN","EASPREC3",60,0) S HLEID="EAS ESR "_STATION_" ORU-"_IVMETC_" SERVER" "RTN","EASPREC3",61,0) I IVMETC="Z04" S HLEID=HLEID_" H" ;HEC TO VAMC "RTN","EASPREC3",62,0) S HLEID=$O(^ORD(101,"B",HLEID,0)),HLEIDS="" "RTN","EASPREC3",63,0) I HLEID]"" S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) "RTN","EASPREC3",64,0) ; "RTN","EASPREC3",65,0) ; - process the message according to the event type code "RTN","EASPREC3",66,0) S IVMDO=$S(IVMETC="Z03":"EN^IVMPREC5",IVMETC="Z04":"EN^IVMPREC3",IVMETC="Z05":"EN^IVMPREC6",IVMETC="Z06":"EN^IVMPREC7",IVMETC="Z08":"EN^IVMPREC4",IVMETC="Z10":"ORU^IVMCM",IVMETC="Z11":"ORUZ11^DGENUPL",1:"ORUQ") "RTN","EASPREC3",67,0) I IVMETC="Z11" D "RTN","EASPREC3",68,0) .D ORUZ11^DGENUPL(HLDA,.IVMERROR) "RTN","EASPREC3",69,0) .S IVMCT=2*IVMERROR "RTN","EASPREC3",70,0) .S HLEVN=IVMERROR "RTN","EASPREC3",71,0) I IVMETC'="Z11" D "RTN","EASPREC3",72,0) .D @IVMDO "RTN","EASPREC3",73,0) Q:IVMDO="ORUQ" "RTN","EASPREC3",74,0) ; "RTN","EASPREC3",75,0) ; - if no error send ACK 'AA' message "RTN","EASPREC3",76,0) S HLMTN="ACK" "RTN","EASPREC3",77,0) K HLARYTYP,HLMTIENA,HLRESLTA,HLP "RTN","EASPREC3",78,0) I 'IVMERROR S HLMID=IVMHLMID D ACK^IVMPREC S HLARYTYP="GM",HLMTIENA="" "RTN","EASPREC3",79,0) I IVMERROR S HLARYTYP="GB",HLMTIENA=HLMTIEN ;HLMTIEN comes from ACK^IVMPREC "RTN","EASPREC3",80,0) K ^TMP("HLA",$J) M ^TMP("HLA",$J)=^TMP("HLS",$J) K ^TMP("HLS",$J) "RTN","EASPREC3",81,0) D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,1,.HLRESLTA,HLMTIENA,.HLP) "RTN","EASPREC3",82,0) ; The following line is added for PFSS Registration. This line will ensure any patient "RTN","EASPREC3",83,0) ; registration updates received from the HEC are forwarded to a COTS billing application "RTN","EASPREC3",84,0) ; See DBIA#4780 - this line will need re enabling if PFSS is active "RTN","EASPREC3",85,0) ;S X="DGPFSS1" X ^%ZOSF("TEST") I $T D SEND^DGPFSS1(DFN,0) "RTN","EASPREC3",86,0) ; "RTN","EASPREC3",87,0) ORUQ ; "RTN","EASPREC3",88,0) K DFN,IVMCNTR,IVMCT,IVMDA,IVMERR,IVMERROR,IVMHLMID,IVMNDE,IVMPTID "RTN","EASPREC3",89,0) K IVMSEG,IVMSEG1,IVMSEG2,IVMSEG3,IVMTEXT,XMSUB "RTN","EASPREC3",90,0) K HLARYTYP,HLMTIENA,HLRESLTA,HLP "RTN","EASPREC3",91,0) K ^TMP($J,IVMRTN),^TMP("HLA",$J),^TMP("HLS",$J) "RTN","EASPREC3",92,0) Q "RTN","EASPREC4") 0^4^B25401092^n/a "RTN","EASPREC4",1,0) EASPREC4 ;ALB/PJH - PROCESS INCOMING HL7 (QRY) MESSAGES ; 11/27/07 3:04pm "RTN","EASPREC4",2,0) ;;1.0;ENROLLMENT APPLICATION SYSTEM;**71**;15-MAR-01;Build 18 "RTN","EASPREC4",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","EASPREC4",4,0) ; "RTN","EASPREC4",5,0) ; CLONED FROM IVMPREC (ESR EVENT DRIVER) "RTN","EASPREC4",6,0) ; "RTN","EASPREC4",7,0) ; This routine will process (QRY) HL7 messages received from HEC "RTN","EASPREC4",8,0) ; At present, the (QRY) message queries for updated information "RTN","EASPREC4",9,0) ; for a single patient. "RTN","EASPREC4",10,0) ; "RTN","EASPREC4",11,0) ; "RTN","EASPREC4",12,0) QRY ; - Receive Query Message requesting further information "RTN","EASPREC4",13,0) ; "RTN","EASPREC4",14,0) S (HLEVN,IVMCT,IVMERROR,IVMFLAG)=0 "RTN","EASPREC4",15,0) ; "RTN","EASPREC4",16,0) K IVMQUERY("LTD"),IVMQUERY("OVIS") ;Variables needed to open/close last visit date and outpt visit QUERIES "RTN","EASPREC4",17,0) S IVMRTN="IVMPREC" "RTN","EASPREC4",18,0) K ^TMP($J,IVMRTN),^TMP("HLS",$J),^TMP("HLA",$J) "RTN","EASPREC4",19,0) F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","EASPREC4",20,0) .S CNT=0 "RTN","EASPREC4",21,0) .S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE "RTN","EASPREC4",22,0) .F S CNT=$O(HLNODE(CNT)) Q:'CNT D "RTN","EASPREC4",23,0) ..S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT) "RTN","EASPREC4",24,0) ; "RTN","EASPREC4",25,0) ; INITIALIZE HL7 VARIABLES "RTN","EASPREC4",26,0) S HLEID="EAS ESR "_$P($$SITE^VASITE,"^",3)_" QRY-Z07 SERVER" "RTN","EASPREC4",27,0) S HLEID=$O(^ORD(101,"B",HLEID,0)) "RTN","EASPREC4",28,0) D INIT^HLFNC2(HLEID,.HL) "RTN","EASPREC4",29,0) S HLEIDS=$O(^ORD(101,HLEID,775,"B",0)) "RTN","EASPREC4",30,0) ; "RTN","EASPREC4",31,0) ; IVM*2.0*105 BAJ 11/02/2005 Temp global for Consistency Checks "RTN","EASPREC4",32,0) K ^TMP($J,"CC") "RTN","EASPREC4",33,0) ; "RTN","EASPREC4",34,0) F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="QRD"!($E(IVMSEG,1,3)="MSH") D "RTN","EASPREC4",35,0) .I $E(IVMSEG,1,3)="MSH" S IVMMSHID=$P(IVMSEG,HLFS,10),MSGID=$P(IVMSEG,HLFS,10),HLMID=MSGID Q "RTN","EASPREC4",36,0) .K HLERR S IVMFLAG=1 "RTN","EASPREC4",37,0) .S IVMSEG=$P(IVMSEG,HLFS,2,999) ; strip off segment name "RTN","EASPREC4",38,0) .S IVMQLR=$P(IVMSEG,HLFS,7),DFN=$P(IVMSEG,HLFS,8),IVMIY=$P(IVMSEG,HLFS,10) "RTN","EASPREC4",39,0) .D ERRCK "RTN","EASPREC4",40,0) .I $D(HLERR) D ACK "RTN","EASPREC4",41,0) .I '$D(HLERR) D "RTN","EASPREC4",42,0) ..N EVENTS "RTN","EASPREC4",43,0) ..; - if master query - create entry in (#301.9) file "RTN","EASPREC4",44,0) ..I IVMQLR>1,'DFN D Q "RTN","EASPREC4",45,0) ...S IVMSEG1="QRD"_HLFS_IVMSEG "RTN","EASPREC4",46,0) ...S:'$D(^IVM(301.9,1,10,0)) ^(0)="^301.9001DA^" "RTN","EASPREC4",47,0) ...S DA(1)=1,DIC="^IVM(301.9,1,10,",DIC(0)="" "RTN","EASPREC4",48,0) ...S X=IVMIY "RTN","EASPREC4",49,0) ...K DO,DD D FILE^DICN "RTN","EASPREC4",50,0) ...S DA=+Y,DA(1)=1,DIE="^IVM(301.9,1,10," "RTN","EASPREC4",51,0) ...S DR=".02///NOW;.04////^S X=IVMMSHID;10////^S X=IVMSEG1" D ^DIE "RTN","EASPREC4",52,0) ..; "RTN","EASPREC4",53,0) ..; Send AE if veteran has a Pseudo SSN and eligibility is not verified "RTN","EASPREC4",54,0) ..;Removed with IVM*2*105 "RTN","EASPREC4",55,0) ..; I '$$SNDPSSN^IVMPTRN7(DFN) S HLERR="Pseudo SSN must be verified" D ACK Q "RTN","EASPREC4",56,0) ..; "RTN","EASPREC4",57,0) ..; - prepare (ACK) message "RTN","EASPREC4",58,0) ..D:'$D(HLERR) MSGHDR ;header (MSH) "RTN","EASPREC4",59,0) ..D ACK ;message (MSA) "RTN","EASPREC4",60,0) ..; "RTN","EASPREC4",61,0) ..; - set up local HL7 event type code in MSH "RTN","EASPREC4",62,0) ..S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="QRD"_HLFS_IVMSEG ; copy of incoming QRD "RTN","EASPREC4",63,0) ..; "RTN","EASPREC4",64,0) ..; - build 'FULL' transmission (note: without MSH segment) "RTN","EASPREC4",65,0) ..S IVMMTDT=$E(IVMIY,1,3)+1_"1231.9999" "RTN","EASPREC4",66,0) ..D FULL^IVMPTRN7(DFN,IVMMTDT,.EVENTS,.IVMCT,.IVMGTOT,,1,,.IVMQUERY) "RTN","EASPREC4",67,0) ; "RTN","EASPREC4",68,0) ; IVM*2.0*105 BAJ 11/02/2005 "RTN","EASPREC4",69,0) ; send AE if inconsistencies found. "RTN","EASPREC4",70,0) I ^TMP($J,"CC",0) S HLERR="Message not sent. Inconsistencies in Record" D ACK "RTN","EASPREC4",71,0) K ^TMP($J,"CC") "RTN","EASPREC4",72,0) ; "RTN","EASPREC4",73,0) F Z="LTD","OVIS" I $G(IVMQUERY(Z)) D CLOSE^SDQ(IVMQUERY(Z)) K IVMQUERY(Z) "RTN","EASPREC4",74,0) I 'IVMFLAG S HLERR="Invalid Message Format" D ACK "RTN","EASPREC4",75,0) S HLMTN="ORF" "RTN","EASPREC4",76,0) S HLMTIENA=HLMTIEN "RTN","EASPREC4",77,0) K ^TMP("HLA",$J) M ^TMP("HLA",$J)=^TMP("HLS",$J) K ^TMP("HLS",$J) "RTN","EASPREC4",78,0) D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,"GB",1,.HLRESLTA,HLMTIENA,.HLP) "RTN","EASPREC4",79,0) ; "RTN","EASPREC4",80,0) QRYQ K DFN,DR,HLEVN,IVMCT,IVMDA,IVMERROR,IVMFLAG,IVMIY,IVMMTDT,IVMSEG,IVMSEG1,IVMQLR,IVMMSHID,MSGID,MSHID "RTN","EASPREC4",81,0) K ^TMP("HLA",$J),^TMP("HLS",$J),^TMP($J,IVMRTN) "RTN","EASPREC4",82,0) Q "RTN","EASPREC4",83,0) ; "RTN","EASPREC4",84,0) ; "RTN","EASPREC4",85,0) ERRCK ; Perform error checks on HL7 (QRD) segment "RTN","EASPREC4",86,0) I ('DFN!(DFN'=+DFN)) S:IVMQLR'>1 HLERR="Invalid DFN" "RTN","EASPREC4",87,0) I '$D(HLERR) S IVMIY=$$FMDATE^HLFNC(IVMIY) I $E(IVMIY,4,7)'="0000"!($E(IVMIY,1,3)<292) S HLERR="Invalid Income Year" "RTN","EASPREC4",88,0) I '$D(HLERR),$P(IVMSEG,HLFS,2)'="R" S HLERR="Invalid Query Format Code" "RTN","EASPREC4",89,0) I '$D(HLERR),$P(IVMSEG,HLFS,3)'="I",($P(IVMSEG,HLFS,3)'="D") S HLERR="Invalid Query Priority" "RTN","EASPREC4",90,0) I '$D(HLERR),$P(IVMSEG,HLFS,9)'="DEM" S HLERR="Invalid Query Subject Filter" "RTN","EASPREC4",91,0) I '$D(HLERR),$P(IVMSEG,HLFS,12)'="T" S HLERR="Invalid Query Results Level" "RTN","EASPREC4",92,0) ; "RTN","EASPREC4",93,0) Q "RTN","EASPREC4",94,0) ; "RTN","EASPREC4",95,0) MSGHDR ; prepare header MSH segment in batch of 100 message events "RTN","EASPREC4",96,0) ; input variables: "RTN","EASPREC4",97,0) ; IVMCT record counter "RTN","EASPREC4",98,0) ; HLEVN event number "RTN","EASPREC4",99,0) ; MSHID outgoing message id "RTN","EASPREC4",100,0) ; HL array for protocol "RTN","EASPREC4",101,0) ; "RTN","EASPREC4",102,0) N MID,HLRES "RTN","EASPREC4",103,0) S HLEVN=$G(HLEVN)+1 "RTN","EASPREC4",104,0) D:(HLEVN#100)=1 "RTN","EASPREC4",105,0) .K MSHID,HLDT,HLDT1,HLMTIEN "RTN","EASPREC4",106,0) .D INIT^HLFNC2(HLEID,.HL) "RTN","EASPREC4",107,0) .D CREATE^HLTF(.MSHID,.HLMTIEN,.HLDT,.HLDT1) "RTN","EASPREC4",108,0) S MID=MSHID_"-"_HLEVN "RTN","EASPREC4",109,0) D MSH^HLFNC2(.HL,MID,.HLRES) "RTN","EASPREC4",110,0) S IVMCT=$G(IVMCT)+1 "RTN","EASPREC4",111,0) S ^TMP("HLS",$J,IVMCT)=HLRES "RTN","EASPREC4",112,0) Q "RTN","EASPREC4",113,0) ; "RTN","EASPREC4",114,0) ACK ; prepare positive and negative acknowledgement (ACK) message "RTN","EASPREC4",115,0) ; (positive acknowledgement: MSA segment with no MSH segment) "RTN","EASPREC4",116,0) ; (negative acknowledgement: MSA segment with MSH segment) "RTN","EASPREC4",117,0) N MID,HLRES "RTN","EASPREC4",118,0) S IVMCT=$G(IVMCT)+1 "RTN","EASPREC4",119,0) D:$D(HLERR) "RTN","EASPREC4",120,0) .S IVMERROR=1 "RTN","EASPREC4",121,0) .S HLEVN=HLEVN+1 "RTN","EASPREC4",122,0) .D:(HLEVN#100)=1 "RTN","EASPREC4",123,0) ..K HLMID,HLMTIEN,HLDT,HLDT1 ; set up batch "RTN","EASPREC4",124,0) ..D INIT^HLFNC2(HLEID,.HL) "RTN","EASPREC4",125,0) ..D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1) "RTN","EASPREC4",126,0) .S MID=HLMID_"-"_HLEVN "RTN","EASPREC4",127,0) .D MSH^HLFNC2(.HL,MID,.HLRES) "RTN","EASPREC4",128,0) .S ^TMP("HLS",$J,IVMCT)=HLRES "RTN","EASPREC4",129,0) .S IVMCT=IVMCT+1 "RTN","EASPREC4",130,0) .S ^TMP("HLS",$J,IVMCT)="MSA"_HLFS_"AE"_HLFS_MSGID_HLFS_HLERR_"- SSN "_$S($G(DFN):$P($$PT^IVMUFNC4(DFN),"^",2),1:"NOT FOUND") "RTN","EASPREC4",131,0) I '$D(HLERR) S ^TMP("HLS",$J,IVMCT)="MSA"_HLFS_"AA"_HLFS_HLMID "RTN","EASPREC4",132,0) ; "RTN","EASPREC4",133,0) Q "RTN","EASPREC4",134,0) ; "VER") 8.0^22.0 "BLD",7093,6) ^71 **END** **END**