EMERGENCY Released SD*5.3*730 SEQ #591 Extracted from mail message **KIDS**:SD*5.3*730^ **INSTALL NAME** SD*5.3*730 "BLD",11344,0) SD*5.3*730^SCHEDULING^0^3190826^y "BLD",11344,4,0) ^9.64PA^^ "BLD",11344,6) 6^ "BLD",11344,6.3) 8 "BLD",11344,"ABPKG") n "BLD",11344,"INI") "BLD",11344,"INID") ^n^ "BLD",11344,"INIT") EN^SDPST730 "BLD",11344,"KRN",0) ^9.67PA^1.5^24 "BLD",11344,"KRN",.4,0) .4 "BLD",11344,"KRN",.401,0) .401 "BLD",11344,"KRN",.402,0) .402 "BLD",11344,"KRN",.403,0) .403 "BLD",11344,"KRN",.5,0) .5 "BLD",11344,"KRN",.84,0) .84 "BLD",11344,"KRN",1.5,0) 1.5 "BLD",11344,"KRN",1.6,0) 1.6 "BLD",11344,"KRN",1.61,0) 1.61 "BLD",11344,"KRN",1.62,0) 1.62 "BLD",11344,"KRN",3.6,0) 3.6 "BLD",11344,"KRN",3.8,0) 3.8 "BLD",11344,"KRN",9.2,0) 9.2 "BLD",11344,"KRN",9.8,0) 9.8 "BLD",11344,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",11344,"KRN",9.8,"NM",1,0) SDCCRSEN^^0^B169705715 "BLD",11344,"KRN",9.8,"NM",2,0) SDPST730^^0^B608255 "BLD",11344,"KRN",9.8,"NM",3,0) SDCCRCOR^^0^B91720288 "BLD",11344,"KRN",9.8,"NM","B","SDCCRCOR",3) "BLD",11344,"KRN",9.8,"NM","B","SDCCRSEN",1) "BLD",11344,"KRN",9.8,"NM","B","SDPST730",2) "BLD",11344,"KRN",19,0) 19 "BLD",11344,"KRN",19.1,0) 19.1 "BLD",11344,"KRN",101,0) 101 "BLD",11344,"KRN",409.61,0) 409.61 "BLD",11344,"KRN",771,0) 771 "BLD",11344,"KRN",779.2,0) 779.2 "BLD",11344,"KRN",870,0) 870 "BLD",11344,"KRN",8989.51,0) 8989.51 "BLD",11344,"KRN",8989.52,0) 8989.52 "BLD",11344,"KRN",8994,0) 8994 "BLD",11344,"KRN","B",.4,.4) "BLD",11344,"KRN","B",.401,.401) "BLD",11344,"KRN","B",.402,.402) "BLD",11344,"KRN","B",.403,.403) "BLD",11344,"KRN","B",.5,.5) "BLD",11344,"KRN","B",.84,.84) "BLD",11344,"KRN","B",1.5,1.5) "BLD",11344,"KRN","B",1.6,1.6) "BLD",11344,"KRN","B",1.61,1.61) "BLD",11344,"KRN","B",1.62,1.62) "BLD",11344,"KRN","B",3.6,3.6) "BLD",11344,"KRN","B",3.8,3.8) "BLD",11344,"KRN","B",9.2,9.2) "BLD",11344,"KRN","B",9.8,9.8) "BLD",11344,"KRN","B",19,19) "BLD",11344,"KRN","B",19.1,19.1) "BLD",11344,"KRN","B",101,101) "BLD",11344,"KRN","B",409.61,409.61) "BLD",11344,"KRN","B",771,771) "BLD",11344,"KRN","B",779.2,779.2) "BLD",11344,"KRN","B",870,870) "BLD",11344,"KRN","B",8989.51,8989.51) "BLD",11344,"KRN","B",8989.52,8989.52) "BLD",11344,"KRN","B",8994,8994) "BLD",11344,"QUES",0) ^9.62^^ "BLD",11344,"REQB",0) ^9.611^1^1 "BLD",11344,"REQB",1,0) SD*5.3*707^1 "BLD",11344,"REQB","B","SD*5.3*707",1) "INIT") EN^SDPST730 "MBREQ") 0 "PKG",16,-1) 1^1 "PKG",16,0) SCHEDULING^SD^APPOINTMENTS,PROFILES,LETTERS,AMIS REPORTS "PKG",16,22,0) ^9.49I^1^1 "PKG",16,22,1,0) 5.3^2930813^2930930 "PKG",16,22,1,"PAH",1,0) 730^3190826^520824646 "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") NO "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") NO "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") NO "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") 3 "RTN","SDCCRCOR") 0^3^B91720288^B91692691 "RTN","SDCCRCOR",1,0) SDCCRCOR ;CCRA/LB,PB - Core Tags;APR 4, 2019 "RTN","SDCCRCOR",2,0) ;;5.3;Scheduling;**707,730**;APR 4, 2019;Build 8 "RTN","SDCCRCOR",3,0) ;;Per VA directive 6402, this routine should not be modified. "RTN","SDCCRCOR",4,0) Q "RTN","SDCCRCOR",5,0) ; "RTN","SDCCRCOR",6,0) HL72VATS(HL7TS) ; Converts HL7 formatted timestamps to VA format "RTN","SDCCRCOR",7,0) ; HL7TS - date/time stamp in 24H HL7 format (YYYYMMDDHHMMSS) "RTN","SDCCRCOR",8,0) Q $$HL7TFM^XLFDT($G(HL7TS)) "RTN","SDCCRCOR",9,0) VA2HL7TS(VATS) ; Converts VA formatted timestamps to HL7 format "RTN","SDCCRCOR",10,0) ; VATS - date/time stamp in VA format (YYYMMDD.HHMMSS) "RTN","SDCCRCOR",11,0) Q $$FMTHL7^XLFDT($G(VATS)) "RTN","SDCCRCOR",12,0) GETPTIEN(PATNAME) ; Returns patient ID or null, name must be perfect match "RTN","SDCCRCOR",13,0) ; PATNAME - Patient name - must be exact LAST,FIRST "RTN","SDCCRCOR",14,0) N IEN "RTN","SDCCRCOR",15,0) I $G(PATNAME)="" Q "" "RTN","SDCCRCOR",16,0) I $D(^DPT("B",PATNAME)) D "RTN","SDCCRCOR",17,0) . S IEN=$O(^DPT("B",PATNAME,"")) "RTN","SDCCRCOR",18,0) Q $G(IEN) "RTN","SDCCRCOR",19,0) GETPTNM(DFN) ; Returns patient name from ^DPT global, given a valid DFN "RTN","SDCCRCOR",20,0) ; DFN - Patient ID to look for "RTN","SDCCRCOR",21,0) N PATNAME "RTN","SDCCRCOR",22,0) I $G(DFN)="" Q "" "RTN","SDCCRCOR",23,0) I $D(^DPT(DFN,0)) D "RTN","SDCCRCOR",24,0) . S PATNAME=$P(^DPT(DFN,0),"^",1) "RTN","SDCCRCOR",25,0) Q $G(PATNAME) "RTN","SDCCRCOR",26,0) GETLCIEN(LOCNAME) ; Returns Location ID or null, name must be perfect match "RTN","SDCCRCOR",27,0) ; PATNAME - Location name - must be exact "RTN","SDCCRCOR",28,0) N IEN "RTN","SDCCRCOR",29,0) I $G(LOCNAME)="" Q "" "RTN","SDCCRCOR",30,0) I $D(^SC("B",LOCNAME)) D "RTN","SDCCRCOR",31,0) . S IEN=$O(^SC("B",LOCNAME,"")) "RTN","SDCCRCOR",32,0) Q $G(IEN) "RTN","SDCCRCOR",33,0) GETLCNM(LOCID) ; Returns location name from clinic file 44 given a valid clinic IEN "RTN","SDCCRCOR",34,0) ; LOCID - Location ID to look for "RTN","SDCCRCOR",35,0) Q $$GET1^DIQ(44,$G(LOCID),.01) "RTN","SDCCRCOR",36,0) GETNMPRV(CLINIC) ; Returns the number of providers associated with a clinic "RTN","SDCCRCOR",37,0) ; CLINIC - The Clinic IEN (first piece of DPT 0 node) "RTN","SDCCRCOR",38,0) Q $P(^SC($G(CLINIC),"PR",0),"^",4) ;Piece 3 is most recently assigned number, piece 4 is total active. "RTN","SDCCRCOR",39,0) GETCNGNM(CLINICGROUP) ; Returns the Name of a Clinic's group "RTN","SDCCRCOR",40,0) ; CLINICGROUP - The Clinic Group IEN "RTN","SDCCRCOR",41,0) Q $P(^SD(409.67,$G(CLINICGROUP),0),"^",1) "RTN","SDCCRCOR",42,0) GETPRVNM(PROVIEN) ; Returns the provider name, given a provider ID "RTN","SDCCRCOR",43,0) ; PROVIEN - The Provider IEN "RTN","SDCCRCOR",44,0) Q $P(^VA(200,$G(PROVIEN),0),"^") "RTN","SDCCRCOR",45,0) ICLNDPRV(CLINIC,PROVIEN) ; Determines if the provider is the default provider for the clinic "RTN","SDCCRCOR",46,0) ; CLINIC - The Clinic IEN (first piece of DPT 0 node) "RTN","SDCCRCOR",47,0) ; PROVIEN - The Provider IEN "RTN","SDCCRCOR",48,0) Q $P(^SC($G(CLINIC),"PR",$$CLNPVIND($G(CLINIC),$G(PROVIEN)),0),"^",2) "RTN","SDCCRCOR",49,0) CLNPVIND(CLINIC,PROVIEN) ; Determines the line number the provider is listed on for a clinic "RTN","SDCCRCOR",50,0) ; CLINIC - The Clinic IEN (first piece of DPT 0 node) "RTN","SDCCRCOR",51,0) ; PROVIEN - The Provider IEN "RTN","SDCCRCOR",52,0) Q +$QS($Q(^SC($G(CLINIC),"PR","B",$G(PROVIEN))),5) "RTN","SDCCRCOR",53,0) GTCANRSN(PATIENTIEN,APPTDT) ; Returns the discrete cancellation reason "RTN","SDCCRCOR",54,0) ; PATIEN (I,REQ)- Patient ID as in DPT(PATIEN,"S",APPTDAT "RTN","SDCCRCOR",55,0) ; APPTDAT (I,REQ) - Appointment date "RTN","SDCCRCOR",56,0) Q $P(^SD(409.2,$$APTNODEP^SDCCRGAP($G(PATIENTIEN),$G(APPTDT),0,15),0),"^",1) "RTN","SDCCRCOR",57,0) GTCNRNTP(PATIENTIEN,APPTDT) ; Gets the cancelation reason type. "RTN","SDCCRCOR",58,0) ; PATIEN - Patient ID as in DPT(PATIEN,"S",APPTDAT "RTN","SDCCRCOR",59,0) ; APPTDAT - Appointment date "RTN","SDCCRCOR",60,0) N VAL,CANTYPE "RTN","SDCCRCOR",61,0) S CANTYPE=$$APTNODEP^SDCCRGAP($G(PATIENTIEN),$G(APPTDT),0,15) "RTN","SDCCRCOR",62,0) S VAL=$P($G(^SD(409.2,$G(CANTYPE),0)),"^",2) "RTN","SDCCRCOR",63,0) Q $S($G(VAL)="B":"C",1:$G(VAL)) "RTN","SDCCRCOR",64,0) ORD2CONS(ORDERID) ;Returns the consult ID linked to the given order "RTN","SDCCRCOR",65,0) ; ORDERID - Order ID "RTN","SDCCRCOR",66,0) N CNSLTLNK "RTN","SDCCRCOR",67,0) I $G(ORDERID)="" Q "" "RTN","SDCCRCOR",68,0) S CNSLTLNK=$G(^OR(100,ORDERID,4)) "RTN","SDCCRCOR",69,0) I $P(CNSLTLNK,";",2)="GMRC" Q $P(CNSLTLNK,";",1) "RTN","SDCCRCOR",70,0) Q "" "RTN","SDCCRCOR",71,0) INSTRING(VALUE,LIST,DELIM) ; compare a string value to see if it is a list given a particular delimiter "RTN","SDCCRCOR",72,0) ; VALUE - value to find in the list. "RTN","SDCCRCOR",73,0) ; LIST - The list to check "RTN","SDCCRCOR",74,0) ; DELIM - Delimiter that separates the data in the list. Default = "," "RTN","SDCCRCOR",75,0) Q $S($G(DELIM)="":(","_$G(LIST)_",")[(","_$G(VALUE)_","),1:($G(DELIM)_$G(LIST)_$G(DELIM))[($G(DELIM)_$G(VALUE)_$G(DELIM))) "RTN","SDCCRCOR",76,0) INITINC ; Sets temp global that indicates this process is filing an incoming message "RTN","SDCCRCOR",77,0) S ^TMP($J,"CCRA-INCINTF")=1 "RTN","SDCCRCOR",78,0) Q "RTN","SDCCRCOR",79,0) DONEINC ; Clears temp global that indicates this process is filing an incoming message "RTN","SDCCRCOR",80,0) K ^TMP($J,"CCRA-INCINTF") "RTN","SDCCRCOR",81,0) Q "RTN","SDCCRCOR",82,0) INCINTF() ; Checks temp global that indicates whether the process is filing an incoming message "RTN","SDCCRCOR",83,0) Q +$G(^TMP($J,"CCRA-INCINTF")) "RTN","SDCCRCOR",84,0) SETMSGET() ;SEND AN ERROR MESSAGE OUT AND LOG THE CACHE ERROR+STACK TO ^ERRORS "RTN","SDCCRCOR",85,0) N $ETRAP "RTN","SDCCRCOR",86,0) S $ETRAP="LOGSEND^SDCCRCOR" "RTN","SDCCRCOR",87,0) Q "RTN","SDCCRCOR",88,0) FMTPHONE(PHONE,EXT) ; Formats a VistA telephone number into an HL7-compliant format "RTN","SDCCRCOR",89,0) ; Formats include: (nnn)nnn-nnnn and nnn-nnnn, depending on whether or not there is an area code. "RTN","SDCCRCOR",90,0) ; If the number is not in an a valid format, does not attempt to do any formatting. "RTN","SDCCRCOR",91,0) ; Returns 1 if the number was formatted, 0 otherwise. "RTN","SDCCRCOR",92,0) ; "RTN","SDCCRCOR",93,0) ; PHONE - Phone number to be formatted "RTN","SDCCRCOR",94,0) ; EXT - Phone number extension (if specified) "RTN","SDCCRCOR",95,0) ; "RTN","SDCCRCOR",96,0) I $G(PHONE)="" Q 0 "RTN","SDCCRCOR",97,0) N TEMP,LENGTH "RTN","SDCCRCOR",98,0) ; "RTN","SDCCRCOR",99,0) ; Extract phone number "RTN","SDCCRCOR",100,0) S TEMP=$$STRIP^XLFSTR(PHONE,"-()") ; Strip certain delimiters "RTN","SDCCRCOR",101,0) S TEMP=$TR(TEMP,"x","X") ; Standardize extension delimiter "RTN","SDCCRCOR",102,0) S EXT=$P(TEMP,"X",2) ; Pull out the extension (if it exists) "RTN","SDCCRCOR",103,0) S TEMP=$P(TEMP,"X",1) "RTN","SDCCRCOR",104,0) ; "RTN","SDCCRCOR",105,0) ; Format based on length "RTN","SDCCRCOR",106,0) S LENGTH=$L(TEMP) "RTN","SDCCRCOR",107,0) I '$$INSTRING^SDCCRCOR(LENGTH,"7,10",",") Q 0 ; Length not 7 or 10 "RTN","SDCCRCOR",108,0) I LENGTH=7 S TEMP=$E(TEMP,1,3)_"-"_$E(TEMP,4,7) ; No area code: nnn-nnnn "RTN","SDCCRCOR",109,0) I LENGTH=10 S TEMP="("_$E(TEMP,1,3)_")"_$E(TEMP,4,6)_"-"_$E(TEMP,7,10) ; Area code: (nnn)nnn-nnnn "RTN","SDCCRCOR",110,0) ; "RTN","SDCCRCOR",111,0) ; Save output "RTN","SDCCRCOR",112,0) S PHONE=TEMP "RTN","SDCCRCOR",113,0) Q 1 "RTN","SDCCRCOR",114,0) GETLEN(SCH,AIP,AIG) ;Translates duration into Minutes. Assumes minutes unless set to S or SEC for the units "RTN","SDCCRCOR",115,0) ; Only one parameter at a time should be passed-in, depending on what segment is calling this tag "RTN","SDCCRCOR",116,0) ; SCH (I/OPT) - SCH message segment data "RTN","SDCCRCOR",117,0) ; AIP (I/OPT) - AIP message segment data "RTN","SDCCRCOR",118,0) ; AIG (I/OPT) - AIG message segment data "RTN","SDCCRCOR",119,0) N DURATION,UNIT "RTN","SDCCRCOR",120,0) I $D(SCH) D "RTN","SDCCRCOR",121,0) . S DURATION=+$$GET^SDCCRSCU(.SCH,9,1) ;SCH-9 "RTN","SDCCRCOR",122,0) . I DURATION=0 D ACK("CE",MID,"SCH",9,1,304,"NO APPOINTMENT DURATION RECIEVED IN SCH",1) S ABORT="1^NO APPOINTMENT DURATION RECIEVED IN SCH" Q "RTN","SDCCRCOR",123,0) . S UNIT=$$GET^SDCCRSCU(.SCH,10,1) ;SCH-10 "RTN","SDCCRCOR",124,0) E I $D(AIP) D "RTN","SDCCRCOR",125,0) . S DURATION=+$$GET^SDCCRSCU(.AIP,9,1) ;AIP-9 "RTN","SDCCRCOR",126,0) . I DURATION=0 D ACK("CE",MID,"AIP",9,1,304,"NO APPOINTMENT DURATION RECIEVED IN AIP",1) S ABORT="1^NO APPOINTMENT DURATION RECIEVED IN AIP" Q "RTN","SDCCRCOR",127,0) . S UNIT=$$GET^SDCCRSCU(.AIP,10,1) ;AIP-10 "RTN","SDCCRCOR",128,0) E I $D(AIG) D "RTN","SDCCRCOR",129,0) . S DURATION=+$$GET^SDCCRSCU(.AIG,11,1) ;AIG-11 "RTN","SDCCRCOR",130,0) . I DURATION=0 D ACK("CE",MID,"AIG",11,1,304,"NO APPOINTMENT DURATION RECIEVED IN AIG",1) S ABORT="1^NO APPOINTMENT DURATION RECIEVED IN AIG" Q "RTN","SDCCRCOR",131,0) . ;S UNIT=$$GET^SDCCRSCU(.AIG,12,1) ;AIG-12 "RTN","SDCCRCOR",132,0) ; Translate to minutes "RTN","SDCCRCOR",133,0) I $$INSTRING^SDCCRCOR(UNIT,"S,SEC") S DURATION=DURATION/60 "RTN","SDCCRCOR",134,0) Q $G(DURATION) "RTN","SDCCRCOR",135,0) COPYMSG(Y) ; Copy HL7 Message to array Y (by reference) "RTN","SDCCRCOR",136,0) ; Based on HL*1.6*56 VISTA HL7 Site Manager & Developer Manual "RTN","SDCCRCOR",137,0) ; Paragraph 9.7, page 9-4 "RTN","SDCCRCOR",138,0) I $L($G(HLNEXT)) ;HL7 context "RTN","SDCCRCOR",139,0) E Q "RTN","SDCCRCOR",140,0) N I,J "RTN","SDCCRCOR",141,0) F I=1:1 X HLNEXT Q:HLQUIT'>0 D "RTN","SDCCRCOR",142,0) .S Y(I)=HLNODE,J=0 "RTN","SDCCRCOR",143,0) .F S J=$O(HLNODE(J)) Q:'J D "RTN","SDCCRCOR",144,0) ..S Y(I)=Y(I)_HLNODE(J) "RTN","SDCCRCOR",145,0) Q "RTN","SDCCRCOR",146,0) ; "RTN","SDCCRCOR",147,0) CHKMSG(Y) ; Check Message for all required segments "RTN","SDCCRCOR",148,0) N QUIT,REQSEG,SEGFND,I,SEGTYP,ICN,DFN,ERRMSG,MSGEVN "RTN","SDCCRCOR",149,0) S QUIT=0 "RTN","SDCCRCOR",150,0) F REQSEG="MSH","SCH","PID","PV1","RGS","AIS","AIG","AIL","AIP" D Q:QUIT "RTN","SDCCRCOR",151,0) .S (SEGFND,I)=0 "RTN","SDCCRCOR",152,0) .F S I=$O(Y(I)) Q:'I!(SEGFND) D "RTN","SDCCRCOR",153,0) ..S SEGTYP=$E(Y(I),1,3) "RTN","SDCCRCOR",154,0) ..I SEGTYP=REQSEG S SEGFND=1 "RTN","SDCCRCOR",155,0) ..I SEGTYP="MSH" D "RTN","SDCCRCOR",156,0) ... I $P(Y(I),FS,10)="" D "RTN","SDCCRCOR",157,0) .... S QUIT=1 "RTN","SDCCRCOR",158,0) .... D ACK("CE",MID,"MSH","",10,101,"MESSAGE CONTROL ID MISSING") "RTN","SDCCRCOR",159,0) .... S ABORT="1^MESSAGE CONTROL ID MISSING" "RTN","SDCCRCOR",160,0) .... Q:QUIT "RTN","SDCCRCOR",161,0) ... I $P($P(Y(I),FS,9),CS,1)'="SIU" D "RTN","SDCCRCOR",162,0) .... S QUIT=1 "RTN","SDCCRCOR",163,0) .... S ERRMSG="Scheduling Message TYPE not received on CCRA scheduling interface. Message type received:"_$P($P(Y(I),FS,9),CS,1) "RTN","SDCCRCOR",164,0) .... S ERRMSG=ERRMSG_" for MESSAGE CONTROL ID:"_$P(Y(I),FS,10) "RTN","SDCCRCOR",165,0) .... D ACK("CE",MID,"MSH","",9,200,ERRMSG) "RTN","SDCCRCOR",166,0) .... S ABORT="1^"_$G(ERRMSG) "RTN","SDCCRCOR",167,0) .... Q:QUIT "RTN","SDCCRCOR",168,0) ... ;determine scheduling action event from message event "RTN","SDCCRCOR",169,0) ... S MSGEVN=$P($P(Y(I),FS,9),CS,2) I $$SETEVENT^SDCCRSEN($G(MSGEVN),.MSGARY)=0 D "RTN","SDCCRCOR",170,0) .... S QUIT=1 "RTN","SDCCRCOR",171,0) .... S ERRMSG="Scheduling Message EVENT could not be determined. Message event received:"_$P($P(Y(I),FS,9),CS,2) "RTN","SDCCRCOR",172,0) .... S ERRMSG=ERRMSG_" for MESSAGE CONTROL ID:"_$P(Y(I),FS,10) "RTN","SDCCRCOR",173,0) .... D ACK("CE",MID,"MSH","",9,201,ERRMSG) "RTN","SDCCRCOR",174,0) .... S ABORT="1^"_$G(ERRMSG) "RTN","SDCCRCOR",175,0) .... Q:QUIT "RTN","SDCCRCOR",176,0) ... S HDRTIME=$P(Y(I),FS,7) "RTN","SDCCRCOR",177,0) .I 'SEGFND D "RTN","SDCCRCOR",178,0) ..S QUIT=1 "RTN","SDCCRCOR",179,0) ..D ACK("CE",MID,REQSEG,"","",100,REQSEG_" SEGMENT MISSING OR OUT OF ORDER") "RTN","SDCCRCOR",180,0) .. S ABORT="1^"_$G(REQSEG)_" SEGMENT MISSING OR OUT OF ORDER" "RTN","SDCCRCOR",181,0) Q QUIT "RTN","SDCCRCOR",182,0) ACK(STAT,MID,SID,SEG,FLD,CD,TXT,ACKTYP) ; Creates ACKs for HL7 Message "RTN","SDCCRCOR",183,0) ;STAT = Status (Acknowledgment Code) (REQUIRED) "RTN","SDCCRCOR",184,0) ;MID = Message ID (REQUIRED) "RTN","SDCCRCOR",185,0) ;SID = Segment ID (set if ERR occurred in segment) (OPTIONAL) "RTN","SDCCRCOR",186,0) ;SEG = Segment location of error (OPTIONAL) "RTN","SDCCRCOR",187,0) ;FLD = Field location of error (OPTIONAL) "RTN","SDCCRCOR",188,0) ;CD = Error Code (OPTIONAL) "RTN","SDCCRCOR",189,0) ;TXT = Text describing error (OPTIONAL) "RTN","SDCCRCOR",190,0) ;ACKTYP = Acknowledgment Type (OPTIONAL) "RTN","SDCCRCOR",191,0) ; "RTN","SDCCRCOR",192,0) N HLA,EID,EIDS,RES,ERRI "RTN","SDCCRCOR",193,0) ; "RTN","SDCCRCOR",194,0) ;Make sure the parameters are defined "RTN","SDCCRCOR",195,0) S STAT=$G(STAT),MID=$G(MID),SID=$G(SID),SEG=$G(SEG) "RTN","SDCCRCOR",196,0) S FLD=$G(FLD),CD=$G(CD),TXT=$G(TXT) "RTN","SDCCRCOR",197,0) ; "RTN","SDCCRCOR",198,0) ;Create MSA Segment "RTN","SDCCRCOR",199,0) S HLA("HLA",1)="MSA"_FS_STAT_FS_MID "RTN","SDCCRCOR",200,0) S EID=$G(HL("EID")) "RTN","SDCCRCOR",201,0) S EIDS=$G(HL("EIDS")) "RTN","SDCCRCOR",202,0) Q:((EID="")!($G(HLMTIENS)="")!(EIDS="")) "RTN","SDCCRCOR",203,0) ; "RTN","SDCCRCOR",204,0) S RES="" "RTN","SDCCRCOR",205,0) ;If Segment ID (SID) is set, create ERR segment "RTN","SDCCRCOR",206,0) D:$L(SID)>0 "RTN","SDCCRCOR",207,0) . K ERRARY "RTN","SDCCRCOR",208,0) . S HLA("HLA",2)="ERR" "RTN","SDCCRCOR",209,0) . S $P(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD "RTN","SDCCRCOR",210,0) . S $P(HLA("HLA",2),FS,5)="E" "RTN","SDCCRCOR",211,0) . ; "RTN","SDCCRCOR",212,0) . ; Commit Error "RTN","SDCCRCOR",213,0) . I '+$G(ACKTYP) D "RTN","SDCCRCOR",214,0) .. S $P(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357" "RTN","SDCCRCOR",215,0) . ; "RTN","SDCCRCOR",216,0) . ; Application Error "RTN","SDCCRCOR",217,0) . I +$G(ACKTYP)=1 D "RTN","SDCCRCOR",218,0) .. S ERRI=0 "RTN","SDCCRCOR",219,0) .. S $P(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT "RTN","SDCCRCOR",220,0) .. ;Process Error "RTN","SDCCRCOR",221,0) .. S ERRI=ERRI+1 "RTN","SDCCRCOR",222,0) .. S ERRARY(ERRI,2)=$P($G(HLA("HLA",2)),"|",3) "RTN","SDCCRCOR",223,0) .. I $P($G(HLA("HLA",2)),"|",6)'="" D ; "RTN","SDCCRCOR",224,0) ... S ERRARY(ERRI,3)=$P($P($G(HLA("HLA",2)),"|",6),"^",4)_"^"_$P($P($G(HLA("HLA",2)),"|",6),"^",5) "RTN","SDCCRCOR",225,0) .. I $P($G(HLA("HLA",2)),"|",6)="" S ERRARY(ERRI,3)=$P($G(HLA("HLA",2)),"|",4) "RTN","SDCCRCOR",226,0) . ;I $D(ERRARY) D MESSAGE(MID,.ERRARY) "RTN","SDCCRCOR",227,0) . ; build message for MailMan "RTN","SDCCRCOR",228,0) D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES) "RTN","SDCCRCOR",229,0) Q "RTN","SDCCRCOR",230,0) ; "RTN","SDCCRCOR",231,0) APPMSG(MSGID,ABORT) ; Send a MailMan Message with the errors "RTN","SDCCRCOR",232,0) N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J "RTN","SDCCRCOR",233,0) S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1))) "RTN","SDCCRCOR",234,0) S XMSUB="Consult: "_$G(CONSULTID)_" - GMRC CCRA Scheduling Issue from HSRM" "RTN","SDCCRCOR",235,0) S MSGTEXT(1)=" " "RTN","SDCCRCOR",236,0) S MSGTEXT(2)="An error in making a community care appointment for consult ID: "_$G(CONSULTID) "RTN","SDCCRCOR",237,0) S MSGTEXT(3)="The consult title is: "_$G(CONTITLE) "RTN","SDCCRCOR",238,0) S MSGTEXT(4)="A non-count clinic named "_$G(SRVNAMEX)_" could not be found." "RTN","SDCCRCOR",239,0) S MSGTEXT(5)="The appointment was for "_$G(PROVIDER)_" on "_$$FMTE^XLFDT(SDECSTART,3) "RTN","SDCCRCOR",240,0) S XMTEXT="MSGTEXT(" "RTN","SDCCRCOR",241,0) S XMDUZ="GMRC-CCRA <-HSRM Transaction Error" "RTN","SDCCRCOR",242,0) S XMDUZ=.5 "RTN","SDCCRCOR",243,0) S XMY("G.GMRC HSRM SIU HL7 MESSAGES")="" ; ** CHECK THIS OUT ** "RTN","SDCCRCOR",244,0) D ^XMD "RTN","SDCCRCOR",245,0) Q "RTN","SDCCRCOR",246,0) MESSAGE(MSGID,ABORT) ; Send a MailMan Message with the errors "RTN","SDCCRCOR",247,0) N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J "RTN","SDCCRCOR",248,0) S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1))) "RTN","SDCCRCOR",249,0) S XMSUB="Consult: "_$G(CONID)_" GMRC CCRA Scheduling Issue from HSRM" "RTN","SDCCRCOR",250,0) S MSGTEXT(1)=" " "RTN","SDCCRCOR",251,0) S MSGTEXT(2)="Error in receiving HL7 message from HSRM" "RTN","SDCCRCOR",252,0) S MSGTEXT(3)="Date: "_DATE "RTN","SDCCRCOR",253,0) S MSGTEXT(4)="Message ID: "_MSGID "RTN","SDCCRCOR",254,0) S MSGTEXT(5)="Error(s): "_$P(ABORT,"^",2) "RTN","SDCCRCOR",255,0) S XMTEXT="MSGTEXT(" "RTN","SDCCRCOR",256,0) S XMDUZ="GMRC-CCRA <-HSRM Transaction Error" "RTN","SDCCRCOR",257,0) S XMDUZ=.5 "RTN","SDCCRCOR",258,0) S XMY("G.GMRC HSRM SIU HL7 MESSAGES")="" "RTN","SDCCRCOR",259,0) D ^XMD "RTN","SDCCRCOR",260,0) Q "RTN","SDCCRCOR",261,0) ANAK(NAKMSG,USERMAIL,ICN,DFN,APTTM,CONID) ; Application Error "RTN","SDCCRCOR",262,0) N PATNAME,EID,EIDS,MSGN,SITE,CONPAT "RTN","SDCCRCOR",263,0) Q:$G(NAKMSG)="" "RTN","SDCCRCOR",264,0) Q:$G(APTTM)="" "RTN","SDCCRCOR",265,0) Q:$G(CONID)="" "RTN","SDCCRCOR",266,0) S CONPAT=$$GET1^DIQ(123,CONID_",",.02,"I"),PATNAME=$$GET1^DIQ(123,CONID_",",.02,"E") "RTN","SDCCRCOR",267,0) S SITE=$$KSP^XUPARAM("INST") "RTN","SDCCRCOR",268,0) S:$G(ICN)="" ICN=$P(^DPT(CONPAT,"MPI"),"^",10) "RTN","SDCCRCOR",269,0) S EID=$G(HL("EID")) "RTN","SDCCRCOR",270,0) S EIDS=$G(HL("EIDS")) "RTN","SDCCRCOR",271,0) S MSGN=$G(HL("MID")) "RTN","SDCCRCOR",272,0) S HLA("HLA",1)="MSA|AE|"_$G(MSGN)_"|"_$G(USERMAIL)_" "_$G(NAKMSG)_"|||"_$G(ICN)_"^"_$G(PATNAME)_"^"_SITE_"^"_CONID_"^"_APTTM "RTN","SDCCRCOR",273,0) D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES) "RTN","SDCCRCOR",274,0) Q "RTN","SDCCRSEN") 0^1^B169705715^B147345634 "RTN","SDCCRSEN",1,0) SDCCRSEN ;CCRA/LB,PB - Appointment retrieval API;APR 4, 2019 "RTN","SDCCRSEN",2,0) ;;5.3;Scheduling;**707,730**;APR 4, 2019;Build 8 "RTN","SDCCRSEN",3,0) ;;Per VA directive 6402, this routine should not be modified. "RTN","SDCCRSEN",4,0) Q "RTN","SDCCRSEN",5,0) ; Documented API's and Integration Agreements "RTN","SDCCRSEN",6,0) ; ---------------------------------------------- "RTN","SDCCRSEN",7,0) ; 2165 GENACK^HLMA1 "RTN","SDCCRSEN",8,0) ; 2701 $$GETDFN^MPIF001 "RTN","SDCCRSEN",9,0) ; 2701 $$GETICN^MPIF001 "RTN","SDCCRSEN",10,0) ; 3535 MAKEADD^TIUSRVP2 "RTN","SDCCRSEN",11,0) ; 10103 $$HL7TFM^XLFDT "RTN","SDCCRSEN",12,0) EN() ;Primary entry routine for HL7 based CCRA scheduling processing. "RTN","SDCCRSEN",13,0) ;Will take all scheduling messages through this one point. "RTN","SDCCRSEN",14,0) N FS,CS,RS,ES,SS,MID,HLQUIT,HLNODE,USER,USERMAIL,NAKMSG,ICN "RTN","SDCCRSEN",15,0) N MSG,HDR,SEG,SEGTYPE,MSGARY,LASTSEG,HDRTIME,ABORT,BASEDT,CLINARY,COUNT,PROVDTL,RESULTS "RTN","SDCCRSEN",16,0) S RESULTS=0 "RTN","SDCCRSEN",17,0) S DUZ="" "RTN","SDCCRSEN",18,0) S FS=$G(HL("FS"),"|") "RTN","SDCCRSEN",19,0) S CS=$E($G(HL("ECH")),1) S:CS="" CS="^" "RTN","SDCCRSEN",20,0) S RS=$E($G(HL("ECH")),2) S:RS="" RS="~" "RTN","SDCCRSEN",21,0) S ES=$E($G(HL("ECH")),3) S:ES="" ES="\" "RTN","SDCCRSEN",22,0) S SS=$E($G(HL("ECH")),4) S:SS="" SS="&" "RTN","SDCCRSEN",23,0) S MID=$G(HL("MID")) "RTN","SDCCRSEN",24,0) S (HLQUIT,HLNODE)=0 "RTN","SDCCRSEN",25,0) ;initialize message from queue "RTN","SDCCRSEN",26,0) D COPYMSG^SDCCRCOR(.MSG) "RTN","SDCCRSEN",27,0) Q:$$CHKMSG^SDCCRCOR(.MSG) "RTN","SDCCRSEN",28,0) Q:$$PROCMSG(.MSG) "RTN","SDCCRSEN",29,0) D ACK^SDCCRCOR("CA",MID) "RTN","SDCCRSEN",30,0) Q "RTN","SDCCRSEN",31,0) PROCMSG(MSG1) ; Process message "RTN","SDCCRSEN",32,0) N QUIT,I,SEGTYPE,ERR1 "RTN","SDCCRSEN",33,0) N GMRCDFN,GMRCTIU,GMRCTIUS,ADDTXT,GMRCATIU,STID,RAWSEG,APTTM,DFN,CONID,CONTITLE,PROVIDER,SRVNAME1,SRVNAMEX "RTN","SDCCRSEN",34,0) K SDECSTART,SDECEND,SDDFN,SDECRES,SDECLEN,SDECNOTE,SDECATID,SDECCR,SDMRTC,SDDDT,SDREQBY,SDLAB,PROVIEN,SDID,SDAPTYP,SDSVCP,SDSVCPR,SDCL,SDEKG,SDXRAY,APPTYPE,EESTAT,OVB,SDPARENT,SDEL "RTN","SDCCRSEN",35,0) S (SDECSTART,SDECEND,SDDFN,SDECRES,SDECLEN,SDECNOTE,SDECATID,SDECCR,SDMRTC,SDDDT,SDREQBY,SDLAB,PROVIEN,SDID,SDAPTYP,SDSVCP,SDSVCPR,SDCL,SDEKG,SDXRAY,APPTYPE,EESTAT,OVB,SDPARENT,SDEL)="" "RTN","SDCCRSEN",36,0) S ABORT=0,BASEDT="" "RTN","SDCCRSEN",37,0) S (QUIT,XX)=0 "RTN","SDCCRSEN",38,0) F S XX=$O(MSG1(XX)) Q:XX'>0 D "RTN","SDCCRSEN",39,0) . Q:+$G(ABORT)>0 "RTN","SDCCRSEN",40,0) . S SEGTYPE=$E(MSG1(XX),1,3),RAWSEG=$G(MSG1(XX)) "RTN","SDCCRSEN",41,0) . I SEGTYPE'="NTE" S LASTSEG=SEGTYPE "RTN","SDCCRSEN",42,0) . S SEG=$G(MSG1(XX)) "RTN","SDCCRSEN",43,0) . I SEGTYPE="SCH" D SCH(SEG,.MSGARY,.ABORT,.BASEDT) ;SCH MUST BE PROCESSED FIRST SOME VALIDATION DEPENDS ON APPOINTMENT STATUS IN SCH-25 "RTN","SDCCRSEN",44,0) . I SEGTYPE="NTE" D NTE(SEG,.MSGARY,LASTSEG,.CLINARY,.ABORT,.PROVDTL) "RTN","SDCCRSEN",45,0) . I SEGTYPE="PID" D PID(SEG,.MSGARY,.ABORT) "RTN","SDCCRSEN",46,0) . I SEGTYPE="PV1" D PV1(SEG,.MSGARY,HDRTIME,.ABORT) "RTN","SDCCRSEN",47,0) . I SEGTYPE="RGS" D RGS(SEG,.MSGARY) "RTN","SDCCRSEN",48,0) . I SEGTYPE="AIS" D AIS(SEG,.MSGARY) "RTN","SDCCRSEN",49,0) . I SEGTYPE="AIG" D AIG(SEG,.MSGARY,.PROVDTL,BASEDT) "RTN","SDCCRSEN",50,0) . I SEGTYPE="AIL" D AIL(SEG,.MSGARY) "RTN","SDCCRSEN",51,0) . I SEGTYPE="AIP" D AIP(SEG,.MSGARY,.PROVDTL,BASEDT) "RTN","SDCCRSEN",52,0) K XX "RTN","SDCCRSEN",53,0) I $G(NAKMSG)'="" S DUZ=.5,QUIT=1 D ANAK^SDCCRCOR($G(NAKMSG),$G(USERMAIL),$G(ICN),$G(DFN),$G(APTTM),$G(CONID)) "RTN","SDCCRSEN",54,0) I +$G(ABORT)=1 D MESSAGE^SDCCRCOR(MID,.ABORT) Q 1 "RTN","SDCCRSEN",55,0) I +$G(ABORT)=2 D APPMSG^SDCCRCOR(MID,.ABORT) Q 1 "RTN","SDCCRSEN",56,0) ;Process Message by Event Type "RTN","SDCCRSEN",57,0) ;ADD NEW APPOINTMENT: "S12"="SCHEDULE" "RTN","SDCCRSEN",58,0) I MSGARY("EVENT")="SCHEDULE" D "RTN","SDCCRSEN",59,0) . S SDECLEN=$P(^SC(SDCL,"SL"),"^",1),SDECAPTID=0 "RTN","SDCCRSEN",60,0) . S:$G(DFN)>0 SDDFN=DFN "RTN","SDCCRSEN",61,0) . S:$G(SDECLEN)'>0 SDECLEN=15 "RTN","SDCCRSEN",62,0) . S:$G(SDDFN)>0 SDECAPTID=$$APPTGET^SDECUTL(SDDFN,BASEDT,SDCL,SDECRES) "RTN","SDCCRSEN",63,0) . I SDECAPTID>0 D ACK^SDCCRCOR("CE",MID,"","","","","Patient already has an appointment at that datetime.",1) "RTN","SDCCRSEN",64,0) . S ABORT="1^Patient already has an appointment at that datetime." "RTN","SDCCRSEN",65,0) . ;I $G(SDECAPTID)'>0 D INP^SDCCRSCU,ARSET^SDECAR2(.RET,.INP) "RTN","SDCCRSEN",66,0) . ;Q:$G(SDECAPTID)>0 "RTN","SDCCRSEN",67,0) . S SDECSTART=$P(SDECSTART,".",1)_"."_$E($P(SDECSTART,".",2),1,4) "RTN","SDCCRSEN",68,0) . S SDECSTART=$$FMTE^XLFDT(SDECSTART,2) "RTN","SDCCRSEN",69,0) . D:QUIT=0 APPADD^SDEC07(.SDECY,SDECSTART,SDECEND,SDDFN,SDECRES,SDECLEN,,,,,,,,,,SDAPTYP,,,SDCL,,,,,1,,"") ;ADD NEW APPOINTMENT "RTN","SDCCRSEN",70,0) ;CANCEL APPOINTMENT: "S15"="CANCEL" "RTN","SDCCRSEN",71,0) I MSGARY("EVENT")="CANCEL" D "RTN","SDCCRSEN",72,0) . S SDECLEN=$P(^SC(SDCL,"SL"),"^",1),SDECAPTID=0 "RTN","SDCCRSEN",73,0) . S:$G(DFN)>0 SDDFN=DFN "RTN","SDCCRSEN",74,0) . S:$G(SDECLEN)'>0 SDECLEN=15 "RTN","SDCCRSEN",75,0) . ;check if appointment exists "RTN","SDCCRSEN",76,0) . ;Retrieve SDECAPTID pointer to SDEC APPOINTMENT file "RTN","SDCCRSEN",77,0) . S:$G(SDDFN)>0 SDECAPTID=$$APPTGET^SDECUTL(SDDFN,BASEDT,SDCL,SDECRES) "RTN","SDCCRSEN",78,0) . S SDECSTART=$P(SDECSTART,".",1)_"."_$E($P(SDECSTART,".",2),1,4) "RTN","SDCCRSEN",79,0) . S SDECSTART=$$FMTE^XLFDT(SDECSTART,2) "RTN","SDCCRSEN",80,0) . I $G(SDECAPTID)=0 D "RTN","SDCCRSEN",81,0) . . D ACK^SDCCRCOR("CE",MID,"","","","","NO APPOINTMENT Found to CANCEL for requested PATIENT,DATE/TIME,and CLINIC",1) "RTN","SDCCRSEN",82,0) . . S ABORT="1^NO APPOINTMENT was found to mark as CANCELED for the PATIENT on "_$G(SDECSTART)_" for consult, "_CONSULTID "RTN","SDCCRSEN",83,0) . . S QUIT=1 "RTN","SDCCRSEN",84,0) . I +$G(ABORT)=1 D MESSAGE^SDCCRCOR(MID,ABORT) Q "RTN","SDCCRSEN",85,0) . D:QUIT=0 APPDEL^SDEC08(.SDECY,SDECAPTID,$G(MSGARY("CANCEL CODE")),$G(MSGARY("CANCEL REASON")),$G(MSGARY("COMMENT")),$G(SDECDATE),$G(MSGARY("USER"))) ;CANCEL APPOINTMENT "RTN","SDCCRSEN",86,0) ;NOSHOW APPOINTMENT: "S26"="NOSHOW" "RTN","SDCCRSEN",87,0) I MSGARY("EVENT")="NOSHOW" D "RTN","SDCCRSEN",88,0) . S SDECLEN=$P(^SC(SDCL,"SL"),"^",1),SDECAPTID=0 "RTN","SDCCRSEN",89,0) . S:$G(DFN)>0 SDDFN=DFN "RTN","SDCCRSEN",90,0) . S:$G(SDECLEN)'>0 SDECLEN=15 "RTN","SDCCRSEN",91,0) . ;check if appointment exists "RTN","SDCCRSEN",92,0) . ;Retrieve SDECAPTID pointer to SDEC APPOINTMENT file "RTN","SDCCRSEN",93,0) . S SDECSTART=$P(SDECSTART,".",1)_"."_$E($P(SDECSTART,".",2),1,4) "RTN","SDCCRSEN",94,0) . S SDECSTART=$$FMTE^XLFDT(SDECSTART,2) "RTN","SDCCRSEN",95,0) . S SDECAPTID=$$APPTGET^SDECUTL(SDDFN,BASEDT,SDCL,SDECRES) "RTN","SDCCRSEN",96,0) . I $G(SDECAPTID)'>0 D "RTN","SDCCRSEN",97,0) . . D ACK^SDCCRCOR("CE",MID,"","","","","NO APPOINTMENT Found to NOSHOW for requested PATIENT,DATE/TIME,and CLINIC",1) "RTN","SDCCRSEN",98,0) . . S ABORT="1^NO APPOINTMENT was found to mark as NO SHOW for the PATIENT on "_$G(SDECSTART)_" for consult, "_CONSULTID "RTN","SDCCRSEN",99,0) . . S QUIT=1 "RTN","SDCCRSEN",100,0) . I +$G(ABORT)=1 D MESSAGE^SDCCRCOR(MID,ABORT) Q "RTN","SDCCRSEN",101,0) . D:QUIT=0 NOSHOW^SDEC31(.SDECY,SDECAPTID,1,$G(MSGARY("USER")),$G(SDECDATE)) "RTN","SDCCRSEN",102,0) D DONEINC^SDCCRCOR "RTN","SDCCRSEN",103,0) K MSG1,SDRES,SDECY,SDECDATE,SDECAPTID,RSNAME,SDAPTYP,SDCL,SDDFN,SDECNOT,SDECNOTE,INP,RET "RTN","SDCCRSEN",104,0) Q QUIT "RTN","SDCCRSEN",105,0) SETEVENT(EVENT,MSGARY) ;Takes the scheduling event and sets a message event to process. "RTN","SDCCRSEN",106,0) ;EVENT (I/REQ) - Message event from the MSH header. EX. S12, S14, S15, S26 "RTN","SDCCRSEN",107,0) ;MSGARY (I/O,REQ) message array structure with reformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",108,0) I $G(EVENT)="" Q 0 "RTN","SDCCRSEN",109,0) I EVENT="S12" S MSGARY("EVENT")="SCHEDULE" Q 1 "RTN","SDCCRSEN",110,0) I EVENT="S14" S MSGARY("EVENT")="UPDATE" Q 1 "RTN","SDCCRSEN",111,0) I EVENT="S15" S MSGARY("EVENT")="CANCEL" Q 1 "RTN","SDCCRSEN",112,0) I EVENT="S26" S MSGARY("EVENT")="NOSHOW" Q 1 "RTN","SDCCRSEN",113,0) Q 0 "RTN","SDCCRSEN",114,0) SCH(SCH,MSGARY,ABORT,BASEDT) ;SCH segment processing.: "RTN","SDCCRSEN",115,0) ;SEG (I/REQ) - SCH message segment data "RTN","SDCCRSEN",116,0) ;MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",117,0) ;ABORT (O,OPT) - Error parameter if we did not receive an appointment date and time. Fatal case to this message. "RTN","SDCCRSEN",118,0) ;BASEDT (O,REQ) - appointment base date/time to use. May be incremented later if processing multiple joint clinic scheduling "RTN","SDCCRSEN",119,0) N ORDIDTYP,SRVNAME,CONSULTID "RTN","SDCCRSEN",120,0) D PARSESEG^SDCCRSCU(SCH,.SCH) "RTN","SDCCRSEN",121,0) S MSGARY("PLACER ID")=$G(SCH(1)) ;SCH-1.1 "RTN","SDCCRSEN",122,0) ;Cancel Reason "RTN","SDCCRSEN",123,0) S CONID=$G(SCH(2)),PROVIDER=$G(SCH(12,1,2))_" "_$G(SCH(12,1,3)) "RTN","SDCCRSEN",124,0) I MSGARY("EVENT")="CANCEL" S MSGARY("CANCEL REASON")=$$GETRSN($G(SCH(6,1,2))),MSGARY("CANCEL CODE")=$G(SCH(6,1,5)) ;SCH-6 "RTN","SDCCRSEN",125,0) ;Duration "RTN","SDCCRSEN",126,0) S (SDECLEN,MSGARY("DURATION"))=$G(SCH(9)) ;SCH-9,10 "RTN","SDCCRSEN",127,0) ;Appointment Date "RTN","SDCCRSEN",128,0) N Y "RTN","SDCCRSEN",129,0) S (SDECSTART,BASEDT)=$$HL7TFM^XLFDT($G(SCH(11,1,4)),"L") ;SCH-11.3 "RTN","SDCCRSEN",130,0) S APTTM=$G(SCH(11,1,4)) "RTN","SDCCRSEN",131,0) N Y S SDECEND=$$HL7TFM^XLFDT($G(SCH(11,1,5)),"L") ;SCH-11.3 "RTN","SDCCRSEN",132,0) I $G(BASEDT)="" S ERR1="NO APPOINTMENT DATE AND TIME" D ACK^SDCCRCOR("CE",MID,"SCH","",11,305,ERR1,1) S ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",133,0) ;User "RTN","SDCCRSEN",134,0) S (MSGARY("USER"))=$$GETUSER($G(SCH(20,1,1))) ;SCH-20 "RTN","SDCCRSEN",135,0) S USERMAIL=$G(SCH(13,1,4)) S:$G(USERMAIL)'="" DUZ=$O(^VA(200,"ADUPN",$$LOW^XLFSTR(USERMAIL),"")) "RTN","SDCCRSEN",136,0) I DUZ'>0 S DUZ=.5,(NAKMSG,ERR1)="SCHEDULER DOESN'T HAVE AN ACCOUNT ON THIS SYSTEM",ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",137,0) S MSGARY("STATUS")=$$GETSTAT($G(SCH(25))) ;SCH-25 "RTN","SDCCRSEN",138,0) ; Linked Consults/Orders "RTN","SDCCRSEN",139,0) S ORDIDTYP=$$GET^SDCCRSCU(.SCH,27,2) ;Placer ID Type "RTN","SDCCRSEN",140,0) Q "RTN","SDCCRSEN",141,0) NTE(NTE,MSGARY,LASTSEG,CLINARY,ABORT,PROVDTL) ;NTE segment processing. "RTN","SDCCRSEN",142,0) ;NTE (I/REQ) - NTE message segment data "RTN","SDCCRSEN",143,0) ;MSGARY (I/O,REQ) - message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",144,0) ;LASTSEG (I,REQ) - segment previous to the NTE to determine context of note. "RTN","SDCCRSEN",145,0) ;CLINARY (I/O,REQ) - List of Clinics to be scheduled. Could contain more than one for joint appointments "RTN","SDCCRSEN",146,0) ;ABORT (O,REQ) - quit parameter to the whole tag. Having one clinic unmapped must stop filing. "RTN","SDCCRSEN",147,0) ;PROVDTL (I/OPT) - passed when NTE concerns a preceding AIP or AIG segment "RTN","SDCCRSEN",148,0) N NOTE,NOTETYPE,CLINIC "RTN","SDCCRSEN",149,0) S LASTSEG=$G(LASTSEG) "RTN","SDCCRSEN",150,0) ;;;lb ===> change to HL7 "RTN","SDCCRSEN",151,0) S NOTE=$$GET^SDCCRSCU(.NTE,3,1) ;NTE-3.1 "RTN","SDCCRSEN",152,0) S NOTETYPE=$$GET^SDCCRSCU(.NTE,4,1) ;NTE-4.1 "RTN","SDCCRSEN",153,0) ;Process NTE following SCH for scheduling comments. "RTN","SDCCRSEN",154,0) S NOTE=$TR(NOTE,"^","?") ;FileMan can't handle "^" "RTN","SDCCRSEN",155,0) I LASTSEG="SCH" D "RTN","SDCCRSEN",156,0) . I ($G(MSGARY("COMMENT"))'=""),(NOTE'="") S MSGARY("COMMENT")=$G(MSGARY("COMMENT"))_" " "RTN","SDCCRSEN",157,0) . S MSGARY("COMMENT")=NOTE "RTN","SDCCRSEN",158,0) ;Process NTE following AIG/AIP for getting clinics "RTN","SDCCRSEN",159,0) I (LASTSEG="AIP")!(LASTSEG="AIG") D "RTN","SDCCRSEN",160,0) . I NOTETYPE="CLINIC" D "RTN","SDCCRSEN",161,0) . . S CLINIC=$$GETCLIN(NOTE) "RTN","SDCCRSEN",162,0) . . I CLINIC="" S ERR1="CLINIC MAPPING ERROR VALUE" D ACK^SDCCRCOR("CE",MID,"NTE","",1,300,ERR1,1) S ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",163,0) . . S CLINARY(0)=$G(CLINARY(0))+1 "RTN","SDCCRSEN",164,0) . . S CLINARY(CLINARY(0))=CLINIC "RTN","SDCCRSEN",165,0) . . S CLINARY(CLINARY(0),"DT")=$G(PROVDTL("DT")) "RTN","SDCCRSEN",166,0) . . S CLINARY(CLINARY(0),"LN")=$G(PROVDTL("LN")) "RTN","SDCCRSEN",167,0) Q "RTN","SDCCRSEN",168,0) PID(PID,MSGARY,ABORT) ;PID segment processing. "RTN","SDCCRSEN",169,0) ;PID (I/REQ) - PID message segment data "RTN","SDCCRSEN",170,0) ;MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",171,0) ;ABORT (O,OPT) - Error parameter if we failed to find a valid patient. Fatal case to this message. "RTN","SDCCRSEN",172,0) N IDENTIFIERS,IENCHECK,OK "RTN","SDCCRSEN",173,0) D PARSESEG^SDCCRSCU(PID,.PID) "RTN","SDCCRSEN",174,0) S ICN=$G(PID(3,1,1)),(SDDFN,DFN)=$$GETDFN^MPIF001($P(ICN,"V")) "RTN","SDCCRSEN",175,0) Q "RTN","SDCCRSEN",176,0) PV1(PV1,MSGARY,HDRTIME,ABORT) ;PV1 segment processing. "RTN","SDCCRSEN",177,0) ;PV1 (I/REQ) - PV1 message segment data "RTN","SDCCRSEN",178,0) ;MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",179,0) ;HDRTIME (I,OPT) - TIME FROM MSH-7, USED AS A DEFAULTING OPTION "RTN","SDCCRSEN",180,0) ;ABORT (O,OPT) - Error parameter if we failed to find a valid patient. Fatal case to this message. "RTN","SDCCRSEN",181,0) N ERROR "RTN","SDCCRSEN",182,0) D PARSESEG^SDCCRSCU(PV1,.PV1) "RTN","SDCCRSEN",183,0) S CONSULTID=0,(CONID,CONSULTID)=$G(PV1(19)) "RTN","SDCCRSEN",184,0) S MSGARY("FILLER ID")=CONSULTID "RTN","SDCCRSEN",185,0) S SDAPTYP="C|"_$G(CONSULTID) "RTN","SDCCRSEN",186,0) N Y,RESNAME "RTN","SDCCRSEN",187,0) S SDECRES=$$GET1^DIQ(123,$G(CONSULTID)_",",1,"I"),(CONTITLE,SRVNAME)=$$GET1^DIQ(123,$G(CONSULTID)_",",1,"E") "RTN","SDCCRSEN",188,0) Q:$G(SRVNAME)'["COMMUNITY CARE" "RTN","SDCCRSEN",189,0) S:$G(SRVNAME)[" - " SRVNAME=$P(SRVNAME," - ",1)_"-"_$P(SRVNAME," - ",2) "RTN","SDCCRSEN",190,0) S:$G(SRVNAME)[" -" SRVNAME=$P(SRVNAME," -",1)_"-"_$P(SRVNAME," -",2) "RTN","SDCCRSEN",191,0) S:$G(SRVNAME)["- " SRVNAME=$P(SRVNAME,"- ",1)_"-"_$P(SRVNAME,"- ",2) "RTN","SDCCRSEN",192,0) S SDCL=$$CHECKLST($G(SRVNAME)) "RTN","SDCCRSEN",193,0) I $G(SDCL)="" S ERROR="NO MATCH FOR "_SRVNAMEX_" PV1-19 CONSULT ID:"_CONSULTID,ERR1=ERROR D ACK^SDCCRCOR("CE",MID,"PV1","",19,305,ERR1,1) S ABORT="2^"_ERR1 Q ;WE NEED AN ERR HERE FOR PV1(19) "RTN","SDCCRSEN",194,0) N SDRES S SDRES=$O(^SDEC(409.831,"B",$G(SRVNAMEX),"")) S:$G(SDRES)>0 SDECRES=$G(SDRES) "RTN","SDCCRSEN",195,0) I $G(SDECRES)="" S ERROR="NO CLINIC RESOURCE MATCH FOR "_SRVNAMEX,ERR1=ERROR D ACK^SDCCRCOR("CE",MID,"PV1","",19,305,ERR1) S ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",196,0) ;ONLY LOG DEFAULTING ERRORS "RTN","SDCCRSEN",197,0) ;CHECK IN DATE/TIME "RTN","SDCCRSEN",198,0) S MSGARY("CHECKINDT")=$$DETTIME($$GET^SDCCRSCU(.PV1,44,1),$G(HDRTIME),.ERROR) ;PV1-44.1 "RTN","SDCCRSEN",199,0) I ($G(ERROR)'=""),($G(MSGARY("STATUS"))="CHECKED IN") D ACK^SDCCRCOR("CE",MID,"PV1","",44,306,"NO CHECK IN TIME IN PV1-44 "_ERROR,1) S ABORT="1^NO CHECK IN TIME IN PV1-44 "_ERROR Q "RTN","SDCCRSEN",200,0) ;CHECK OUT DATE/TIME "RTN","SDCCRSEN",201,0) S MSGARY("CHECKOUTDT")=$$DETTIME($$GET^SDCCRSCU(.PV1,45,1),$G(HDRTIME),.ERROR) ;PV1-45.1 "RTN","SDCCRSEN",202,0) I ($G(ERROR)'=""),($G(MSGARY("STATUS"))="CHECKED OUT") D ACK^SDCCRCOR("CE",MID,"PV1","",45,307,"NO CHECK IN TIME IN PV1-45 "_ERROR,1) S ABORT="1^NO CHECK IN TIME IN PV1-44 "_ERROR Q "RTN","SDCCRSEN",203,0) Q "RTN","SDCCRSEN",204,0) RGS(RGS,MSGARY) ; RGS segment processing. "RTN","SDCCRSEN",205,0) ;Per HL7 this segment repeats and has multiple AIS/AIG/AIP segments underneath. "RTN","SDCCRSEN",206,0) ;RGS (I/REQ) - RGS message segment data "RTN","SDCCRSEN",207,0) ; MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",208,0) Q "RTN","SDCCRSEN",209,0) AIS(AIS,MSGARY) ;AIS segment processing. "RTN","SDCCRSEN",210,0) ;Per HL7 this field can repeat within each RGS group. "RTN","SDCCRSEN",211,0) ;AIS (I/REQ) - AIS message segment data "RTN","SDCCRSEN",212,0) ;MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",213,0) Q "RTN","SDCCRSEN",214,0) AIP(AIP,MSGARY,PROVDTL,BASEDTE) ;AIP segment processing. "RTN","SDCCRSEN",215,0) ;Per HL7 this field can repeat within each RGS group. "RTN","SDCCRSEN",216,0) ;AIP (I/REQ) - AIP message segment data "RTN","SDCCRSEN",217,0) ;MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",218,0) ;PROVDTL (O,REQ) - AIP date/time and length "RTN","SDCCRSEN",219,0) ;BASEDTE (I,REQ) - Appt D/T from SCH "RTN","SDCCRSEN",220,0) D PARSESEG^SDCCRSCU(AIP,.AIP) "RTN","SDCCRSEN",221,0) I $$HL7TFM^XLFDT($$GET^SDCCRSCU(.AIP,6,1),"L")'="" S PROVDTL("DT")=$$HL7TFM^XLFDT($$GET^SDCCRSCU(.AIP,6,1),"L") ;AIP-6 "RTN","SDCCRSEN",222,0) E S PROVDTL("DT")=BASEDTE "RTN","SDCCRSEN",223,0) S PROVDTL("LN")=MSGARY("DURATION") "RTN","SDCCRSEN",224,0) Q "RTN","SDCCRSEN",225,0) ; "RTN","SDCCRSEN",226,0) AIL(AIL,RETVAL) ; Process AIL Segment "RTN","SDCCRSEN",227,0) Q "RTN","SDCCRSEN",228,0) AIG(AIG,MSGARY,PROVDTL,BASEDTE) ;AIG segment processing. "RTN","SDCCRSEN",229,0) ;Per HL7 this field can repeat within each RGS group. "RTN","SDCCRSEN",230,0) ;AIG (I/REQ) - AIG message segment data "RTN","SDCCRSEN",231,0) ;MSGARY (I/O,REQ) message array structure with deformated and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",232,0) ;PROVDTL (O,REQ) - AIG date/time and length "RTN","SDCCRSEN",233,0) ;BASEDTE (I,REQ) - Appt D/T from SCH "RTN","SDCCRSEN",234,0) D PARSESEG^SDCCRSCU(AIG,.AIG) "RTN","SDCCRSEN",235,0) I $$HL7TFM^XLFDT($$GET^SDCCRSCU(.AIG,8,1),"L")'="" S PROVDTL("DT")=$$HL7TFM^XLFDT($$GET^SDCCRSCU(.AIG,8,1),"L") ;AIG-8 "RTN","SDCCRSEN",236,0) E S PROVDTL("DT")=BASEDTE "RTN","SDCCRSEN",237,0) S PROVDTL("LN")=MSGARY("DURATION") "RTN","SDCCRSEN",238,0) Q "RTN","SDCCRSEN",239,0) ; "RTN","SDCCRSEN",240,0) GETRSN(SCH) ; Collects appointment reason and translates into internal format. "RTN","SDCCRSEN",241,0) ;Tries using the Title to lookup the reason. If that fails uses the ID to lookup "RTN","SDCCRSEN",242,0) ;the reason against the title. If that fails tries using the ID against the ID. "RTN","SDCCRSEN",243,0) ;SCH (I/REQ) - SCH message segment data "RTN","SDCCRSEN",244,0) Q $$DATALKUP(.SCH,"409.2","^SD(409.2,",6,302,"APPOINTMENT REASON MAPPING ERROR") "RTN","SDCCRSEN",245,0) GETTYPE(OBX) ;translates appointment type into internal format "RTN","SDCCRSEN",246,0) ;OBX (I/REQ) - OBX message segment data "RTN","SDCCRSEN",247,0) N APPTTYPE "RTN","SDCCRSEN",248,0) S APPTTYPE=$$DATALKUP(.OBX,"409.1","^SD(409.1,",5,303,"APPOINTMENT TYPE MAPPING ERROR") "RTN","SDCCRSEN",249,0) I $G(APPTTYPE)="" S APPTTYPE=9 "RTN","SDCCRSEN",250,0) Q APPTTYPE "RTN","SDCCRSEN",251,0) ; "RTN","SDCCRSEN",252,0) GETUSER(SCH) ;collects appointment entered by user and confirms they are a user in the 200 file "RTN","SDCCRSEN",253,0) ;SCH (I/REQ) - SCH message segment data "RTN","SDCCRSEN",254,0) Q:$G(SCH)="" "RTN","SDCCRSEN",255,0) S USER=$$FIND1^DIC(200,,"X",$G(SCH),"ASECID",,"SCERR") "RTN","SDCCRSEN",256,0) S USER=.5 "RTN","SDCCRSEN",257,0) Q USER "RTN","SDCCRSEN",258,0) GETSTAT(SCH) ; Translates status into appropriate scheduling statuses "RTN","SDCCRSEN",259,0) ;Options: (SCHEDULED,CHECKED IN,CHECKED OUT,CANCELLED,NO SHOW) "RTN","SDCCRSEN",260,0) ;SCH (I/REQ) - SCH message segment data "RTN","SDCCRSEN",261,0) N STATUS,ID,TITLE "RTN","SDCCRSEN",262,0) S ID=$$GET^SDCCRSCU(.SCH,25,1) "RTN","SDCCRSEN",263,0) S TITLE=$$GET^SDCCRSCU(.SCH,25,2) "RTN","SDCCRSEN",264,0) I $$INSTRING^SDCCRCOR(TITLE,"SCHEDULED,CHECKED IN,CHECKED OUT,CANCELLED,NO SHOW") Q TITLE "RTN","SDCCRSEN",265,0) I $$INSTRING^SDCCRCOR(ID,"SCHEDULED,CHECKED IN,CHECKED OUT,CANCELLED,NO SHOW") Q ID "RTN","SDCCRSEN",266,0) I (ID'="")!(TITLE'="") D ACK^SDCCRCOR("CE",MID,"SCH",25,"",309,"SCHEDULING STATUS MAPPING ERROR",1) S ABORT="1^SCHEDULING STATUS MAPPING ERROR" Q "RTN","SDCCRSEN",267,0) Q "NA" "RTN","SDCCRSEN",268,0) GETIDS(PID,IDENTIFIERS) ;Loops over PID-3 and extracts all IDs out into an array. Currently will identify ICN and IEN identifiers only "RTN","SDCCRSEN",269,0) ;PID (I,REQ) - PID message segment data "RTN","SDCCRSEN",270,0) ;IDENTIFIERS (O,REQ) - Identifier array to return "RTN","SDCCRSEN",271,0) K IDS ;force output parameter "RTN","SDCCRSEN",272,0) N REP,ID,ASSIGN,IDTYPE "RTN","SDCCRSEN",273,0) S ID=PID(3,1,5) "RTN","SDCCRSEN",274,0) S IDENTIFIERS("PATIENT IEN")=$G(PID(3,2,1)) ;DFN "RTN","SDCCRSEN",275,0) S IDENTIFIERS("PATIENT ICN")=$G(PID(3,1,1)) ;ICN "RTN","SDCCRSEN",276,0) Q "RTN","SDCCRSEN",277,0) ISPATIEN(ASSIGN,IDTYPE) ;Determines if given id descriptors are the IEN for this instance "RTN","SDCCRSEN",278,0) ;ASSIGN (I,OPT) - Assigning Authority of this identifier "RTN","SDCCRSEN",279,0) ;IDTYPE (I,OPT) - ID Type of this identifier "RTN","SDCCRSEN",280,0) I $G(IDTYPE)="IEN" Q 1 "RTN","SDCCRSEN",281,0) Q 0 "RTN","SDCCRSEN",282,0) ISPATICN(ASSIGN,IDTYPE) ;Determines if given id descriptors are the ICN for this instance "RTN","SDCCRSEN",283,0) ;ASSIGN (I,OPT) - Assigning Authority of this identifier "RTN","SDCCRSEN",284,0) ;IDTYPE (I,OPT) - ID Type of this identifier "RTN","SDCCRSEN",285,0) I $G(IDTYPE)="ICN" Q 1 "RTN","SDCCRSEN",286,0) Q 0 "RTN","SDCCRSEN",287,0) GTIENICN(PATICN) ;Lookup the IEN for a given ICN "RTN","SDCCRSEN",288,0) ;PATICN (I,REQ) - Patient ICN "RTN","SDCCRSEN",289,0) ;IDTYPE (I,OPT) - ID Type of this identifier "RTN","SDCCRSEN",290,0) N PATIEN "RTN","SDCCRSEN",291,0) S PATIEN="" "RTN","SDCCRSEN",292,0) Q PATIEN "RTN","SDCCRSEN",293,0) GETCLIN(ID) ;Collects clinic from the PV1-3.1 segment. There is no title component to this data type. "RTN","SDCCRSEN",294,0) ;ID (I/REQ) - Clinic string to lookup clinic with "RTN","SDCCRSEN",295,0) ;Check Requirements "RTN","SDCCRSEN",296,0) I $G(ID)="" Q "" "RTN","SDCCRSEN",297,0) N CLINIC "RTN","SDCCRSEN",298,0) ; Try robust multi tier lookup "RTN","SDCCRSEN",299,0) S CLINIC=$O(^SC("B",ID,"")) "RTN","SDCCRSEN",300,0) I CLINIC'="" Q CLINIC "RTN","SDCCRSEN",301,0) I $G(^SC(ID,0))'="" Q ID "RTN","SDCCRSEN",302,0) Q "" "RTN","SDCCRSEN",303,0) GETELIG(OBX) ;Collects appointment eligibility and translates into internal format "RTN","SDCCRSEN",304,0) ;Tries using the Title to lookup the eligibility. If that fails uses the "RTN","SDCCRSEN",305,0) ;ID to lookup the reason against the title. If that fails tries using the ID against the ID. "RTN","SDCCRSEN",306,0) ;OBX (I/REQ) - OBX message segment data "RTN","SDCCRSEN",307,0) Q $$DATALKUP(.OBX,"8","^DIC(8,",5) "RTN","SDCCRSEN",308,0) DETTIME(PV1TIME,HDRTIME,ERROR) ;RETURNS THE BEST CHECK IN/OUT TIME AVAILABLE IN THE MESSAGE OR DEFAULTS TO NOW "RTN","SDCCRSEN",309,0) ;PV1TIME (I,OPT) - HIGHEST PRIORITY TIME TO RETURN FROM EITHER PV1-44 OR PV1-45 "RTN","SDCCRSEN",310,0) ;HDRTIME (I,OPT) - TIME FROM MSH-7 "RTN","SDCCRSEN",311,0) ;ERROR (O,OPT) - ERROR OUTPUT PARAMETER "RTN","SDCCRSEN",312,0) K ERROR "RTN","SDCCRSEN",313,0) I $G(PV1TIME)'="" Q $$HL7TFM^XLFDT(PV1TIME,"L") "RTN","SDCCRSEN",314,0) I $G(HDRTIME)'="" S ERROR="FALLING BACK TO MSH-7" Q $$HL7TFM^XLFDT(HDRTIME,"L") "RTN","SDCCRSEN",315,0) S ERROR="FALLING BACK TO FILING TIME" "RTN","SDCCRSEN",316,0) Q $$NOW^XLFDT() "RTN","SDCCRSEN",317,0) DATALKUP(SEG,FILE,FILEPATH,FIELD,ERRCODE,ERRTEXT) ; Translates a data element for a given FileMan file in an HL7 field "RTN","SDCCRSEN",318,0) ;Tries using the Title to lookup the data. If that fails uses the ID to lookup "RTN","SDCCRSEN",319,0) ;the reason against the title. If that fails tries using the ID against the ID. "RTN","SDCCRSEN",320,0) ;SEG (I,REQ) - Message segment to parse "RTN","SDCCRSEN",321,0) ;FILE (I,REQ) - FileMan File to lookup "RTN","SDCCRSEN",322,0) ;FILEPATH (I,REQ) - global path to the file's storage location for DIC lookup. Make sure to end with a comma ^(, "RTN","SDCCRSEN",323,0) ;FIELD (I,REQ) - message field to look in "RTN","SDCCRSEN",324,0) ;ERRCODE (I,OPT) - error to log if failure "RTN","SDCCRSEN",325,0) ;ERRTEXT (I,OPT) - error text to log if failure "RTN","SDCCRSEN",326,0) ;Check Requirements "RTN","SDCCRSEN",327,0) I ($G(FILE)="")!($G(FIELD)="") Q "RTN","SDCCRSEN",328,0) N ID,TITLE,DATA,X,Y,DIC "RTN","SDCCRSEN",329,0) S DATA="" "RTN","SDCCRSEN",330,0) S ID=$$GET^SDCCRSCU(.SEG,FIELD,1) ;component 1 HL7 ID field "RTN","SDCCRSEN",331,0) S TITLE=$$GET^SDCCRSCU(.SEG,FIELD,2) ;component 2 HL7 Title field "RTN","SDCCRSEN",332,0) I (ID=""),(TITLE="") Q "" ;No data to translate "RTN","SDCCRSEN",333,0) ; Try robust mutli tier lookup "RTN","SDCCRSEN",334,0) I TITLE'="" S DIC=FILEPATH,DIC(0)="B",X=TITLE D ^DIC S DATA=$P(Y,"^",1) ;lookup "B" node with the second component "RTN","SDCCRSEN",335,0) I DATA'="",DATA'=-1 Q DATA "RTN","SDCCRSEN",336,0) I ID'="" d "RTN","SDCCRSEN",337,0) . S DIC=FILEPATH,DIC(0)="B",X=ID D ^DIC S DATA=$P(Y,"^",1) ;lookup "B" node with the first component "RTN","SDCCRSEN",338,0) . I DATA'="",DATA'=-1 Q "RTN","SDCCRSEN",339,0) . I $$GET1^DIQ(FILE,ID,".01")'="" S DATA=ID ;check if the ID matches a record in the File. if so use it. "RTN","SDCCRSEN",340,0) I DATA'="" Q DATA "RTN","SDCCRSEN",341,0) I $G(ERRCODE)'="" D ACK^SDCCRCOR("CE",MID,"","","",ERRCODE,ERRTEXT,1) ;All lookups have failed and data exists so send an error "RTN","SDCCRSEN",342,0) Q "" "RTN","SDCCRSEN",343,0) CHECKLST(SRVNAME) ; "RTN","SDCCRSEN",344,0) ; lookup matching clinic for imaging comm care consults "RTN","SDCCRSEN",345,0) I $G(SRVNAME)="" Q 0 "RTN","SDCCRSEN",346,0) N CLINID,CLINIC,CONTITLE "RTN","SDCCRSEN",347,0) S CONTITLE=SRVNAME "RTN","SDCCRSEN",348,0) S (RSNAME,SRVNAME)="COM CARE-"_$P($P(SRVNAME,"COMMUNITY CARE",2),"-",2),SRVNAME=$E(SRVNAME,1,30) S:$E(SRVNAME,30)=" " SRVNAME=$E(SRVNAME,1,29) "RTN","SDCCRSEN",349,0) S:$E($P(RSNAME,"-",2),1,3)="DOD" (RSNAME,SRVNAME)="CC-"_$P(RSNAME,"-",2) "RTN","SDCCRSEN",350,0) S CLINID=$O(^SC("B",$E($G(SRVNAME),1,30),"")) "RTN","SDCCRSEN",351,0) I $G(CLINID)'>0 D "RTN","SDCCRSEN",352,0) .F I=1:1:7 D "RTN","SDCCRSEN",353,0) ..Q:$G(CLINID)>0 "RTN","SDCCRSEN",354,0) ..I $P($P($T(LIST+I),";;",2),"^",1)=CONTITLE S CLINIC=$P($P($T(LIST+I),";;",2),"^",2),CLINID=$O(^SC("B",$G(CLINIC),"")),SRVNAME=CLINIC "RTN","SDCCRSEN",355,0) I CLINID'>0 D "RTN","SDCCRSEN",356,0) . N LENG,SRVNAME1 "RTN","SDCCRSEN",357,0) . S LENG=0 "RTN","SDCCRSEN",358,0) . S LENG=$L(SRVNAME) "RTN","SDCCRSEN",359,0) . S (SRVNAME,SRVNAME1)=$S(LENG>28:$E(SRVNAME,1,28)_"-X",1:$G(SRVNAME)_"-X"),CLINID=$O(^SC("B",$G(SRVNAME1),"")) "RTN","SDCCRSEN",360,0) S SRVNAMEX=SRVNAME "RTN","SDCCRSEN",361,0) Q CLINID "RTN","SDCCRSEN",362,0) LIST ; List of Imaging Community Care consult titles and clinics "RTN","SDCCRSEN",363,0) ;;COMMUNITY CARE-IMAGING CT-AUTO^COM CARE-IMAG CT-AUTO "RTN","SDCCRSEN",364,0) ;;COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO^COM CARE-IMAG GEN RAD-AUTO "RTN","SDCCRSEN",365,0) ;;COMMUNITY CARE-IMAGING MAGNETIC RESONANCE IMAGING-AUTO^COM CARE-IMAG MRI-AUTO "RTN","SDCCRSEN",366,0) ;;COMMUNITY CARE-IMAGING MAMMOGRAPHY DIAGNOSTIC-AUTO^COM CARE-IMAG MAM DIAG-AUTO "RTN","SDCCRSEN",367,0) ;;COMMUNITY CARE-IMAGING MAMMOGRAPHY SCREEN-AUTO^COM CARE-IMAG MAM SCR-AUTO "RTN","SDCCRSEN",368,0) ;;COMMUNITY CARE-IMAGING NUCLEAR MEDICINE-AUTO^COM CARE-IMAG NUC MEC-AUTO "RTN","SDCCRSEN",369,0) ;;COMMUNITY CARE-IMAGING ULTRASOUND-AUTO^COM CARE-IMAG U/S-AUTO "RTN","SDPST730") 0^2^B608255^n/a "RTN","SDPST730",1,0) SDPST730 ;HSRM/PB CCRA PRE INSTALL;APR 22, 2019 "RTN","SDPST730",2,0) ;;5.3;Scheduling;**730**;APR 4, 2019;Build 8 "RTN","SDPST730",3,0) ;;Per VA directive 6402, this routine should not be modified. "RTN","SDPST730",4,0) ;Pre install routine for patch SD*5.3*730. "RTN","SDPST730",5,0) ;Sets the Auto Start FIELD (#4.5) in the HL LOGICAL LINK FILE to Enabled "RTN","SDPST730",6,0) Q "RTN","SDPST730",7,0) EN ; "RTN","SDPST730",8,0) N X,DIC,Y,X,SDIEN,SDFDA,SDMSG "RTN","SDPST730",9,0) K DIC(0) "RTN","SDPST730",10,0) S X="CCRA-NAK",DIC(0)="QEZ",DIC="^HLCS(870," D ^DIC "RTN","SDPST730",11,0) Q:+$G(Y)'>0 "RTN","SDPST730",12,0) S SDIEN=+Y_"," "RTN","SDPST730",13,0) S SDFDA(870,SDIEN,4.5)=1 "RTN","SDPST730",14,0) D UPDATE^DIE("","SDFDA","SDIEN","SDMSG") "RTN","SDPST730",15,0) K X,DIC,Y,SDIEN,SDFDA,SDMSG,Y,X,DIC(0) "RTN","SDPST730",16,0) Q "VER") 8.0^22.2 "BLD",11344,6) ^591 **END** **END**