EMERGENCY Released SD*5.3*735 SEQ #604 Extracted from mail message **KIDS**:SD*5.3*735^ **INSTALL NAME** SD*5.3*735 "BLD",11450,0) SD*5.3*735^SCHEDULING^0^3200324^y "BLD",11450,4,0) ^9.64PA^^ "BLD",11450,6) 6^ "BLD",11450,6.3) 21 "BLD",11450,"ABPKG") n "BLD",11450,"INI") "BLD",11450,"INID") ^n^ "BLD",11450,"INIT") EN^SDPST735 "BLD",11450,"KRN",0) ^9.67PA^1.5^24 "BLD",11450,"KRN",.4,0) .4 "BLD",11450,"KRN",.401,0) .401 "BLD",11450,"KRN",.402,0) .402 "BLD",11450,"KRN",.403,0) .403 "BLD",11450,"KRN",.5,0) .5 "BLD",11450,"KRN",.84,0) .84 "BLD",11450,"KRN",1.5,0) 1.5 "BLD",11450,"KRN",1.6,0) 1.6 "BLD",11450,"KRN",1.61,0) 1.61 "BLD",11450,"KRN",1.62,0) 1.62 "BLD",11450,"KRN",3.6,0) 3.6 "BLD",11450,"KRN",3.8,0) 3.8 "BLD",11450,"KRN",9.2,0) 9.2 "BLD",11450,"KRN",9.8,0) 9.8 "BLD",11450,"KRN",9.8,"NM",0) ^9.68A^4^3 "BLD",11450,"KRN",9.8,"NM",1,0) SDCCRSEN^^0^B183223052 "BLD",11450,"KRN",9.8,"NM",3,0) SDCCRCOR^^0^B132572414 "BLD",11450,"KRN",9.8,"NM",4,0) SDPST735^^0^B3238326 "BLD",11450,"KRN",9.8,"NM","B","SDCCRCOR",3) "BLD",11450,"KRN",9.8,"NM","B","SDCCRSEN",1) "BLD",11450,"KRN",9.8,"NM","B","SDPST735",4) "BLD",11450,"KRN",19,0) 19 "BLD",11450,"KRN",19.1,0) 19.1 "BLD",11450,"KRN",101,0) 101 "BLD",11450,"KRN",409.61,0) 409.61 "BLD",11450,"KRN",771,0) 771 "BLD",11450,"KRN",779.2,0) 779.2 "BLD",11450,"KRN",870,0) 870 "BLD",11450,"KRN",8989.51,0) 8989.51 "BLD",11450,"KRN",8989.52,0) 8989.52 "BLD",11450,"KRN",8994,0) 8994 "BLD",11450,"KRN","B",.4,.4) "BLD",11450,"KRN","B",.401,.401) "BLD",11450,"KRN","B",.402,.402) "BLD",11450,"KRN","B",.403,.403) "BLD",11450,"KRN","B",.5,.5) "BLD",11450,"KRN","B",.84,.84) "BLD",11450,"KRN","B",1.5,1.5) "BLD",11450,"KRN","B",1.6,1.6) "BLD",11450,"KRN","B",1.61,1.61) "BLD",11450,"KRN","B",1.62,1.62) "BLD",11450,"KRN","B",3.6,3.6) "BLD",11450,"KRN","B",3.8,3.8) "BLD",11450,"KRN","B",9.2,9.2) "BLD",11450,"KRN","B",9.8,9.8) "BLD",11450,"KRN","B",19,19) "BLD",11450,"KRN","B",19.1,19.1) "BLD",11450,"KRN","B",101,101) "BLD",11450,"KRN","B",409.61,409.61) "BLD",11450,"KRN","B",771,771) "BLD",11450,"KRN","B",779.2,779.2) "BLD",11450,"KRN","B",870,870) "BLD",11450,"KRN","B",8989.51,8989.51) "BLD",11450,"KRN","B",8989.52,8989.52) "BLD",11450,"KRN","B",8994,8994) "BLD",11450,"QUES",0) ^9.62^^ "BLD",11450,"REQB",0) ^9.611^1^1 "BLD",11450,"REQB",1,0) SD*5.3*730^1 "BLD",11450,"REQB","B","SD*5.3*730",1) "INIT") EN^SDPST735 "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) 735^3200324^520824644 "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^B132572414^B91720288 "RTN","SDCCRCOR",1,0) SDCCRCOR ;CCRA/LB,PB - Core Tags;APR 4, 2019 "RTN","SDCCRCOR",2,0) ;;5.3;Scheduling;**707,730,735**;APR 4, 2019;Build 21 "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 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) DATALKUP(SEG,FILE,FILEPATH,FIELD,ERRCODE,ERRTEXT) ; Translates a data element for a given FileMan file in an HL7 field "RTN","SDCCRCOR",183,0) ;Tries using the Title to lookup the data. If that fails uses the ID to lookup "RTN","SDCCRCOR",184,0) ;the reason against the title. If that fails tries using the ID against the ID. "RTN","SDCCRCOR",185,0) ;SEG (I,REQ) - Message segment to parse "RTN","SDCCRCOR",186,0) ;FILE (I,REQ) - FileMan File to lookup "RTN","SDCCRCOR",187,0) ;FILEPATH (I,REQ) - global path to the file's storage location for DIC lookup. Make sure to end with a comma ^(, "RTN","SDCCRCOR",188,0) ;FIELD (I,REQ) - message field to look in "RTN","SDCCRCOR",189,0) ;ERRCODE (I,OPT) - error to log if failure "RTN","SDCCRCOR",190,0) ;ERRTEXT (I,OPT) - error text to log if failure "RTN","SDCCRCOR",191,0) ;Check Requirements "RTN","SDCCRCOR",192,0) I ($G(FILE)="")!($G(FIELD)="") Q "RTN","SDCCRCOR",193,0) N ID,TITLE,DATA,X,Y,DIC "RTN","SDCCRCOR",194,0) S DATA="" "RTN","SDCCRCOR",195,0) S ID=$$GET^SDCCRSCU(.SEG,FIELD,1) ;component 1 HL7 ID field "RTN","SDCCRCOR",196,0) S TITLE=$$GET^SDCCRSCU(.SEG,FIELD,2) ;component 2 HL7 Title field "RTN","SDCCRCOR",197,0) I (ID=""),(TITLE="") Q "" ;No data to translate "RTN","SDCCRCOR",198,0) ; Try robust mutli tier lookup "RTN","SDCCRCOR",199,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","SDCCRCOR",200,0) I DATA'="",DATA'=-1 Q DATA "RTN","SDCCRCOR",201,0) I ID'="" d "RTN","SDCCRCOR",202,0) . S DIC=FILEPATH,DIC(0)="B",X=ID D ^DIC S DATA=$P(Y,"^",1) ;lookup "B" node with the first component "RTN","SDCCRCOR",203,0) . I DATA'="",DATA'=-1 Q "RTN","SDCCRCOR",204,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","SDCCRCOR",205,0) I DATA'="" Q DATA "RTN","SDCCRCOR",206,0) I $G(ERRCODE)'="" D ACK^SDCCRCOR("CE",MID,"","","",ERRCODE,ERRTEXT,1) ;All lookups have failed and data exists so send an error "RTN","SDCCRCOR",207,0) Q "" "RTN","SDCCRCOR",208,0) ACK(STAT,MID,SID,SEG,FLD,CD,TXT,ACKTYP) ; Creates ACKs for HL7 Message "RTN","SDCCRCOR",209,0) ;STAT = Status (Acknowledgment Code) (REQUIRED) "RTN","SDCCRCOR",210,0) ;MID = Message ID (REQUIRED) "RTN","SDCCRCOR",211,0) ;SID = Segment ID (set if ERR occurred in segment) (OPTIONAL) "RTN","SDCCRCOR",212,0) ;SEG = Segment location of error (OPTIONAL) "RTN","SDCCRCOR",213,0) ;FLD = Field location of error (OPTIONAL) "RTN","SDCCRCOR",214,0) ;CD = Error Code (OPTIONAL) "RTN","SDCCRCOR",215,0) ;TXT = Text describing error (OPTIONAL) "RTN","SDCCRCOR",216,0) ;ACKTYP = Acknowledgment Type (OPTIONAL) "RTN","SDCCRCOR",217,0) ; "RTN","SDCCRCOR",218,0) N HLA,EID,EIDS,RES,ERRI,CS,FS,RS,ES,SS ;Jan 21,2020 - PB - patch 735 new and then set FS,CS,RS,ES,SS "RTN","SDCCRCOR",219,0) S FS=$G(HL("FS"),"|") "RTN","SDCCRCOR",220,0) S CS=$E($G(HL("ECH")),1) S:CS="" CS="^" "RTN","SDCCRCOR",221,0) S RS=$E($G(HL("ECH")),2) S:RS="" RS="~" "RTN","SDCCRCOR",222,0) S ES=$E($G(HL("ECH")),3) S:ES="" ES="\" "RTN","SDCCRCOR",223,0) S SS=$E($G(HL("ECH")),4) S:SS="" SS="&" "RTN","SDCCRCOR",224,0) ; "RTN","SDCCRCOR",225,0) ;Make sure the parameters are defined "RTN","SDCCRCOR",226,0) S STAT=$G(STAT),MID=$G(MID),SID=$G(SID),SEG=$G(SEG) "RTN","SDCCRCOR",227,0) S FLD=$G(FLD),CD=$G(CD),TXT=$G(TXT) "RTN","SDCCRCOR",228,0) ; "RTN","SDCCRCOR",229,0) ;Create MSA Segment "RTN","SDCCRCOR",230,0) S HLA("HLA",1)="MSA"_FS_STAT_FS_MID_FS_$G(TXT) "RTN","SDCCRCOR",231,0) S EID=$G(HL("EID")) "RTN","SDCCRCOR",232,0) S EIDS=$G(HL("EIDS")) "RTN","SDCCRCOR",233,0) Q:((EID="")!($G(HLMTIENS)="")!(EIDS="")) "RTN","SDCCRCOR",234,0) ; "RTN","SDCCRCOR",235,0) S RES="" "RTN","SDCCRCOR",236,0) ;If Segment ID (SID) is set, create ERR segment "RTN","SDCCRCOR",237,0) D:$L(SID)>0 "RTN","SDCCRCOR",238,0) . K ERRARY "RTN","SDCCRCOR",239,0) . S HLA("HLA",2)="ERR" "RTN","SDCCRCOR",240,0) . S $P(HLA("HLA",2),FS,3)=SID_CS_SEG_CS_FLD "RTN","SDCCRCOR",241,0) . S $P(HLA("HLA",2),FS,5)="E" "RTN","SDCCRCOR",242,0) . ; "RTN","SDCCRCOR",243,0) . ; Commit Error "RTN","SDCCRCOR",244,0) . I '+$G(ACKTYP) D "RTN","SDCCRCOR",245,0) .. S $P(HLA("HLA",2),FS,4)=CD_CS_TXT_CS_"0357" "RTN","SDCCRCOR",246,0) . ; "RTN","SDCCRCOR",247,0) . ; Application Error "RTN","SDCCRCOR",248,0) . I +$G(ACKTYP)=1 D "RTN","SDCCRCOR",249,0) .. S ERRI=0 "RTN","SDCCRCOR",250,0) .. S $P(HLA("HLA",2),FS,6)=CS_CS_CS_CD_CS_TXT "RTN","SDCCRCOR",251,0) .. ;Process Error "RTN","SDCCRCOR",252,0) .. S ERRI=ERRI+1 "RTN","SDCCRCOR",253,0) .. S ERRARY(ERRI,2)=$P($G(HLA("HLA",2)),"|",3) "RTN","SDCCRCOR",254,0) .. I $P($G(HLA("HLA",2)),"|",6)'="" D ; "RTN","SDCCRCOR",255,0) ... S ERRARY(ERRI,3)=$P($P($G(HLA("HLA",2)),"|",6),"^",4)_"^"_$P($P($G(HLA("HLA",2)),"|",6),"^",5) "RTN","SDCCRCOR",256,0) .. I $P($G(HLA("HLA",2)),"|",6)="" S ERRARY(ERRI,3)=$P($G(HLA("HLA",2)),"|",4) "RTN","SDCCRCOR",257,0) . ;I $D(ERRARY) D MESSAGE(MID,.ERRARY) "RTN","SDCCRCOR",258,0) . ; build message for MailMan "RTN","SDCCRCOR",259,0) D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES) "RTN","SDCCRCOR",260,0) Q "RTN","SDCCRCOR",261,0) ; "RTN","SDCCRCOR",262,0) APPMSG(MSGID,ABORT) ; Send a MailMan Message with the errors "RTN","SDCCRCOR",263,0) N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J "RTN","SDCCRCOR",264,0) S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1))) "RTN","SDCCRCOR",265,0) S XMSUB="Consult: "_$G(CONSULTID)_" - GMRC CCRA Scheduling Issue from HSRM" "RTN","SDCCRCOR",266,0) S MSGTEXT(1)=" " "RTN","SDCCRCOR",267,0) S MSGTEXT(2)="An error in making a community care appointment for consult ID: "_$G(CONSULTID) "RTN","SDCCRCOR",268,0) S MSGTEXT(3)="The consult title is: "_$G(CONTITLE) "RTN","SDCCRCOR",269,0) S MSGTEXT(4)="A non-count clinic named "_$G(SRVNAMEX)_" could not be found." "RTN","SDCCRCOR",270,0) S MSGTEXT(5)="The appointment was for "_$G(PROVIDER)_" on "_$$FMTE^XLFDT(SDECSTART,3) "RTN","SDCCRCOR",271,0) S XMTEXT="MSGTEXT(" "RTN","SDCCRCOR",272,0) S XMDUZ="GMRC-CCRA <-HSRM Transaction Error" "RTN","SDCCRCOR",273,0) S XMDUZ=.5 "RTN","SDCCRCOR",274,0) S XMY("G.GMRC HSRM SIU HL7 MESSAGES")="" ; ** CHECK THIS OUT ** "RTN","SDCCRCOR",275,0) D ^XMD "RTN","SDCCRCOR",276,0) Q "RTN","SDCCRCOR",277,0) MESSAGE(MSGID,ABORT) ; Send a MailMan Message with the errors "RTN","SDCCRCOR",278,0) N MSGTEXT,DUZ,XMDUZ,XMSUB,XMTEXT,XMY,XMMG,XMSTRIP,XMROU,DIFROM,XMYBLOB,XMZ,XMMG,DATE,J,FLG1 "RTN","SDCCRCOR",279,0) S DATE=$$FMTE^XLFDT($$FMDATE^HLFNC($P(HL("DTM"),"-",1))) "RTN","SDCCRCOR",280,0) S XMSUB="Consult: "_$G(CONID)_" GMRC CCRA Scheduling Issue from HSRM" "RTN","SDCCRCOR",281,0) S:$E($P($G(ABORT),"^",2),1,9)="SCHEDULER" FLG1=1 "RTN","SDCCRCOR",282,0) S MSGTEXT(1)=" " "RTN","SDCCRCOR",283,0) S MSGTEXT(2)="Error in receiving HL7 message from HSRM" "RTN","SDCCRCOR",284,0) S MSGTEXT(3)="Date: "_DATE "RTN","SDCCRCOR",285,0) S MSGTEXT(4)="Message ID: "_MSGID "RTN","SDCCRCOR",286,0) S MSGTEXT(5)="Error(s): "_$P(ABORT,"^",2)_" "_$G(USERMAIL) "RTN","SDCCRCOR",287,0) ;Jan 21,2020 - PB - patch 735 add email from message and the email searched for "RTN","SDCCRCOR",288,0) S:$G(FLG1)=1 MSGTEXT(6)="Scheduler email from HSRM "_$G(USERMAIL)_" looking for "_$$LOW^XLFSTR(USERMAIL) "RTN","SDCCRCOR",289,0) S XMTEXT="MSGTEXT(" "RTN","SDCCRCOR",290,0) S XMDUZ="GMRC-CCRA <-HSRM Transaction Error" "RTN","SDCCRCOR",291,0) S XMDUZ=.5 "RTN","SDCCRCOR",292,0) S XMY("G.GMRC HSRM SIU HL7 MESSAGES")="" "RTN","SDCCRCOR",293,0) D ^XMD "RTN","SDCCRCOR",294,0) Q "RTN","SDCCRCOR",295,0) ANAK(NAKMSG,USERMAIL,ICN,DFN,APTTM,CONID) ; Application Error "RTN","SDCCRCOR",296,0) N PATNAME,EID,EIDS,MSGN,SITE,CONPAT,CS,FS,RS,ES,SS ;Jan 21,2020 - PB - patch 735 new and then set FS,CS,RS,ES,SS "RTN","SDCCRCOR",297,0) S FS=$G(HL("FS"),"|") "RTN","SDCCRCOR",298,0) S CS=$E($G(HL("ECH")),1) S:CS="" CS="^" "RTN","SDCCRCOR",299,0) S RS=$E($G(HL("ECH")),2) S:RS="" RS="~" "RTN","SDCCRCOR",300,0) S ES=$E($G(HL("ECH")),3) S:ES="" ES="\" "RTN","SDCCRCOR",301,0) S SS=$E($G(HL("ECH")),4) S:SS="" SS="&" "RTN","SDCCRCOR",302,0) Q:$G(NAKMSG)="" "RTN","SDCCRCOR",303,0) Q:$G(APTTM)="" "RTN","SDCCRCOR",304,0) Q:$G(CONID)="" "RTN","SDCCRCOR",305,0) S CONPAT=$$GET1^DIQ(123,CONID_",",.02,"I") "RTN","SDCCRCOR",306,0) S:$G(CONPAT)>0 PATNAME=$$GET1^DIQ(123,CONID_",",.02,"E") "RTN","SDCCRCOR",307,0) S:$G(CONPAT)'>0 PATNAME=$$GET1^DIQ(123,$G(DFN)_","_.02,"E") "RTN","SDCCRCOR",308,0) S SITE=$$KSP^XUPARAM("INST") "RTN","SDCCRCOR",309,0) I $G(ICN)="" S:$G(CONPAT)>0 ICN=$P(^DPT(CONPAT,"MPI"),"^",10) "RTN","SDCCRCOR",310,0) I $G(ICN)="" S ICN="NOT IN MSG" "RTN","SDCCRCOR",311,0) S EID=$G(HL("EID")) "RTN","SDCCRCOR",312,0) S EIDS=$G(HL("EIDS")) "RTN","SDCCRCOR",313,0) S MSGN=$G(HL("MID")) "RTN","SDCCRCOR",314,0) S HLA("HLA",1)="MSA|AE|"_$G(MSGN)_"|"_$G(USERMAIL)_" "_$G(NAKMSG)_"|||"_$G(ICN)_"^"_$G(PATNAME)_"^"_SITE_"^"_CONID_"^"_APTTM "RTN","SDCCRCOR",315,0) D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES) "RTN","SDCCRCOR",316,0) Q "RTN","SDCCRCOR",317,0) INT ; "RTN","SDCCRCOR",318,0) S RESULTS=0 "RTN","SDCCRCOR",319,0) S DUZ="" "RTN","SDCCRCOR",320,0) S FS=$G(HL("FS"),"|") "RTN","SDCCRCOR",321,0) S CS=$E($G(HL("ECH")),1) S:CS="" CS="^" "RTN","SDCCRCOR",322,0) S RS=$E($G(HL("ECH")),2) S:RS="" RS="~" "RTN","SDCCRCOR",323,0) S ES=$E($G(HL("ECH")),3) S:ES="" ES="\" "RTN","SDCCRCOR",324,0) S SS=$E($G(HL("ECH")),4) S:SS="" SS="&" "RTN","SDCCRCOR",325,0) S MID=$G(HL("MID")) "RTN","SDCCRCOR",326,0) S (HLQUIT,HLNODE)=0 "RTN","SDCCRCOR",327,0) Q "RTN","SDCCRSEN") 0^1^B183223052^B169705715 "RTN","SDCCRSEN",1,0) SDCCRSEN ;CCRA/LB,PB - Appointment retrieval API;APR 4, 2019 "RTN","SDCCRSEN",2,0) ;;5.3;Scheduling;**707,730,735**;APR 4, 2019;Build 21 "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) D INT^SDCCRCOR "RTN","SDCCRSEN",17,0) D COPYMSG^SDCCRCOR(.MSG) "RTN","SDCCRSEN",18,0) Q:$$CHKMSG^SDCCRCOR(.MSG) "RTN","SDCCRSEN",19,0) Q:$$PROCMSG(.MSG) "RTN","SDCCRSEN",20,0) D ACK^SDCCRCOR("CA",MID) "RTN","SDCCRSEN",21,0) Q "RTN","SDCCRSEN",22,0) PROCMSG(MSG1) ; Process message "RTN","SDCCRSEN",23,0) N QUIT,I,SEGTYPE,ERR1 "RTN","SDCCRSEN",24,0) N GMRCDFN,GMRCTIU,GMRCTIUS,CID,ADDTXT,GMRCATIU,STID,RAWSEG,APTTM,DFN,CONID,CONTITLE,PROVIDER,SRVNAME1,SRVNAMEX,LOC,PROV,SDECRESA "RTN","SDCCRSEN",25,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",26,0) S (SDECSTART,SDECEND,SDDFN,SDECRES,SDECLEN,CID,PROV,LOC,SDECNOTE,SDECATID,SDECCR,SDMRTC,SDDDT,SDREQBY,SDLAB,PROVIEN,SDID,SDAPTYP,SDSVCP,SDSVCPR,SDCL,SDEKG,SDXRAY,APPTYPE,EESTAT,OVB,SDPARENT,SDEL)="" "RTN","SDCCRSEN",27,0) S ABORT=0,BASEDT="" "RTN","SDCCRSEN",28,0) S (QUIT,XX)=0 "RTN","SDCCRSEN",29,0) F S XX=$O(MSG1(XX)) Q:XX'>0 D "RTN","SDCCRSEN",30,0) . ;Q:+$G(ABORT)>0 "RTN","SDCCRSEN",31,0) . S SEGTYPE=$E(MSG1(XX),1,3),RAWSEG=$G(MSG1(XX)) "RTN","SDCCRSEN",32,0) . I SEGTYPE'="NTE" S LASTSEG=SEGTYPE "RTN","SDCCRSEN",33,0) . S SEG=$G(MSG1(XX)) "RTN","SDCCRSEN",34,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",35,0) . I SEGTYPE="NTE" D NTE(SEG,.MSGARY,LASTSEG,.CLINARY,.ABORT,.PROVDTL) "RTN","SDCCRSEN",36,0) . I SEGTYPE="PID" D PID(SEG,.MSGARY,.ABORT) "RTN","SDCCRSEN",37,0) . I SEGTYPE="PV1" D PV1(SEG,.MSGARY,HDRTIME,.ABORT) "RTN","SDCCRSEN",38,0) . I SEGTYPE="RGS" D RGS(SEG,.MSGARY) "RTN","SDCCRSEN",39,0) . I SEGTYPE="AIS" D AIS(SEG,.MSGARY) "RTN","SDCCRSEN",40,0) . I SEGTYPE="AIG" D AIG(SEG,.MSGARY,.PROVDTL,BASEDT) "RTN","SDCCRSEN",41,0) . I SEGTYPE="AIL" D AIL(SEG,.MSGARY) "RTN","SDCCRSEN",42,0) . I SEGTYPE="AIP" D AIP(SEG,.MSGARY,.PROVDTL,BASEDT) "RTN","SDCCRSEN",43,0) K XX "RTN","SDCCRSEN",44,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",45,0) I +$G(ABORT)=1 D MESSAGE^SDCCRCOR(MID,.ABORT) Q 1 "RTN","SDCCRSEN",46,0) I +$G(ABORT)=2 D APPMSG^SDCCRCOR(MID,.ABORT) Q 1 "RTN","SDCCRSEN",47,0) S QUIT=0 "RTN","SDCCRSEN",48,0) I MSGARY("EVENT")="SCHEDULE" D MAKE "RTN","SDCCRSEN",49,0) I MSGARY("EVENT")="CANCEL" D CANCEL "RTN","SDCCRSEN",50,0) I MSGARY("EVENT")="NOSHOW" D NOSHOW "RTN","SDCCRSEN",51,0) D DONEINC^SDCCRCOR "RTN","SDCCRSEN",52,0) K MSG1,SDRES,SDECY,SDECDATE,SDECAPTID,RSNAME,SDAPTYP,SDCL,SDDFN,SDECNOT,SDECNOTE,INP,RET "RTN","SDCCRSEN",53,0) Q QUIT "RTN","SDCCRSEN",54,0) MAKE ;MAKE APPOINTMENT: "S12"="SCHEDULE" "RTN","SDCCRSEN",55,0) S SDECLEN=$P(^SC(SDCL,"SL"),"^",1),SDECAPTID=0 "RTN","SDCCRSEN",56,0) S:$G(DFN)>0 SDDFN=DFN "RTN","SDCCRSEN",57,0) S:$G(SDECLEN)'>0 SDECLEN=15 "RTN","SDCCRSEN",58,0) S:$G(SDDFN)>0 SDECAPTID=$$APPTGET^SDECUTL(SDDFN,BASEDT,SDCL,SDECRES) "RTN","SDCCRSEN",59,0) I SDECAPTID>0 D ACK^SDCCRCOR("CE",MID,"","","","","Patient already has an appointment at that datetime.",1) D "RTN","SDCCRSEN",60,0) .S ABORT="1^Patient already has an appointment at that datetime.",QUIT=1 "RTN","SDCCRSEN",61,0) .D MESSAGE^SDCCRCOR(MID,.ABORT) Q "RTN","SDCCRSEN",62,0) Q:$G(QUIT)=1 "RTN","SDCCRSEN",63,0) S SDECSTART=$P(SDECSTART,".",1)_"."_$E($P(SDECSTART,".",2),1,4) "RTN","SDCCRSEN",64,0) S SDECSTART=$$FMTE^XLFDT(SDECSTART,2) "RTN","SDCCRSEN",65,0) S SDECNOTE="HSRM, PID="_$G(CID)_" PER CONSULT, PROVIDER "_$G(PROV) "RTN","SDCCRSEN",66,0) D:QUIT=0 APPADD^SDEC07(.SDECY,SDECSTART,SDECEND,SDDFN,SDECRES,SDECLEN,$G(SDECNOTE),,,,,,,,,SDAPTYP,,,SDCL,,,,,1,,"") ;ADD NEW APPOINTMENT "RTN","SDCCRSEN",67,0) ;735 - PB Check to see if the appointment was made. "RTN","SDCCRSEN",68,0) I +$G(^TMP("SDEC07",$J,2))>0 Q "RTN","SDCCRSEN",69,0) I $P($G(^TMP("SDEC07",$J,3)),"^",2)'="" S ABORT="1^"_$P($G(^TMP("SDEC07",$J,3)),"^",2) D "RTN","SDCCRSEN",70,0) .D MESSAGE^SDCCRCOR(MID,.ABORT) "RTN","SDCCRSEN",71,0) .D ANAK^SDCCRCOR($P($G(ABORT),"^",2),$G(USERMAIL),$G(ICN),$G(DFN),$G(APTTM),$G(CONID)) "RTN","SDCCRSEN",72,0) Q "RTN","SDCCRSEN",73,0) CANCEL ;CANCEL APPOINTMENT: "S15"="CANCEL" "RTN","SDCCRSEN",74,0) S SDECLEN=$P(^SC(SDCL,"SL"),"^",1),SDECAPTID=0 "RTN","SDCCRSEN",75,0) S:$G(DFN)>0 SDDFN=DFN "RTN","SDCCRSEN",76,0) S:$G(SDECLEN)'>0 SDECLEN=15 "RTN","SDCCRSEN",77,0) ;check if appointment exists "RTN","SDCCRSEN",78,0) ;Retrieve SDECAPTID pointer to SDEC APPOINTMENT file "RTN","SDCCRSEN",79,0) S:$G(SDDFN)>0 SDECAPTID=$$APPTGET^SDECUTL(SDDFN,BASEDT,SDCL,SDECRES) "RTN","SDCCRSEN",80,0) S SDECSTART=$P(SDECSTART,".",1)_"."_$E($P(SDECSTART,".",2),1,4) "RTN","SDCCRSEN",81,0) S SDECSTART=$$FMTE^XLFDT(SDECSTART,2) "RTN","SDCCRSEN",82,0) I $G(SDECAPTID)=0 D "RTN","SDCCRSEN",83,0) .D ACK^SDCCRCOR("CE",MID,"","","","","NO APPOINTMENT Found to CANCEL for requested PATIENT,DATE/TIME,and CLINIC",1) "RTN","SDCCRSEN",84,0) .S ABORT="1^NO APPOINTMENT was found to mark as CANCELED for the PATIENT on "_$G(SDECSTART)_" for consult, "_CONSULTID "RTN","SDCCRSEN",85,0) .S QUIT=1 "RTN","SDCCRSEN",86,0) I +$G(ABORT)=1 D MESSAGE^SDCCRCOR(MID,ABORT) Q "RTN","SDCCRSEN",87,0) S:$G(MSGARY("CANCEL CODE"))="" MSGARY("CANCEL CODE")="C" "RTN","SDCCRSEN",88,0) S:$G(MSGARY("CANCEL REASON"))="" MSGARY("CANCEL REASON")=11 "RTN","SDCCRSEN",89,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",90,0) ;735 - PB Check to see if the appointment was made. "RTN","SDCCRSEN",91,0) I +$G(^TMP("SDEC07",$J,2))>0 Q "RTN","SDCCRSEN",92,0) I $P($G(^TMP("SDEC07",$J,3)),"^",2)'="" S ABORT="1^"_$P($G(^TMP("SDEC07",$J,3)),"^",2) D "RTN","SDCCRSEN",93,0) .D MESSAGE^SDCCRCOR(MID,.ABORT) "RTN","SDCCRSEN",94,0) .D ANAK^SDCCRCOR($P($G(ABORT),"^",2),$G(USERMAIL),$G(ICN),$G(DFN),$G(APTTM),$G(CONID)) "RTN","SDCCRSEN",95,0) Q "RTN","SDCCRSEN",96,0) NOSHOW ;NOSHOW APPOINTMENT: "S26"="NOSHOW" "RTN","SDCCRSEN",97,0) S SDECLEN=$P(^SC(SDCL,"SL"),"^",1),SDECAPTID=0 "RTN","SDCCRSEN",98,0) S:$G(DFN)>0 SDDFN=DFN "RTN","SDCCRSEN",99,0) S:$G(SDECLEN)'>0 SDECLEN=15 "RTN","SDCCRSEN",100,0) ;check if appointment exists "RTN","SDCCRSEN",101,0) ;Retrieve SDECAPTID pointer to SDEC APPOINTMENT file "RTN","SDCCRSEN",102,0) S SDECSTART=$P(SDECSTART,".",1)_"."_$E($P(SDECSTART,".",2),1,4) "RTN","SDCCRSEN",103,0) S SDECSTART=$$FMTE^XLFDT(SDECSTART,2) "RTN","SDCCRSEN",104,0) S SDECAPTID=$$APPTGET^SDECUTL(SDDFN,BASEDT,SDCL,SDECRES) "RTN","SDCCRSEN",105,0) I $G(SDECAPTID)'>0 D "RTN","SDCCRSEN",106,0) .D ACK^SDCCRCOR("CE",MID,"","","","","NO APPOINTMENT Found to NOSHOW for requested PATIENT,DATE/TIME,and CLINIC",1) "RTN","SDCCRSEN",107,0) .S ABORT="1^NO APPOINTMENT was found to mark as NO SHOW for the PATIENT on "_$G(SDECSTART)_" for consult, "_CONSULTID "RTN","SDCCRSEN",108,0) .S QUIT=1 "RTN","SDCCRSEN",109,0) I +$G(ABORT)=1 D MESSAGE^SDCCRCOR(MID,ABORT) Q "RTN","SDCCRSEN",110,0) D:QUIT=0 NOSHOW^SDEC31(.SDECY,SDECAPTID,1,$G(MSGARY("USER")),$G(SDECDATE)) "RTN","SDCCRSEN",111,0) ;735 - PB Check to see if the appointment was made. "RTN","SDCCRSEN",112,0) I +$G(^TMP("SDEC07",$J,2))>0 Q "RTN","SDCCRSEN",113,0) I $P($G(^TMP("SDEC07",$J,3)),"^",2)'="" S ABORT="1^"_$P($G(^TMP("SDEC07",$J,3)),"^",2) D "RTN","SDCCRSEN",114,0) .D MESSAGE^SDCCRCOR(MID,.ABORT) "RTN","SDCCRSEN",115,0) .D ANAK^SDCCRCOR($P($G(ABORT),"^",2),$G(USERMAIL),$G(ICN),$G(DFN),$G(APTTM),$G(CONID)) "RTN","SDCCRSEN",116,0) Q "RTN","SDCCRSEN",117,0) SETEVENT(EVENT,MSGARY) ;Takes the scheduling event and sets a message event to process. "RTN","SDCCRSEN",118,0) ;EVENT (I/REQ) - Message event from the MSH header. EX. S12, S14, S15, S26 "RTN","SDCCRSEN",119,0) ;MSGARY (I/O,REQ) message array structure with reformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",120,0) I $G(EVENT)="" Q 0 "RTN","SDCCRSEN",121,0) I EVENT="S12" S MSGARY("EVENT")="SCHEDULE" Q 1 "RTN","SDCCRSEN",122,0) I EVENT="S15" S MSGARY("EVENT")="CANCEL" Q 1 "RTN","SDCCRSEN",123,0) I EVENT="S26" S MSGARY("EVENT")="NOSHOW" Q 1 "RTN","SDCCRSEN",124,0) Q 0 "RTN","SDCCRSEN",125,0) SCH(SCH,MSGARY,ABORT,BASEDT) ;SCH segment processing.: "RTN","SDCCRSEN",126,0) ;SEG (I/REQ) - SCH message segment data "RTN","SDCCRSEN",127,0) ;MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",128,0) ;ABORT (O,OPT) - Error parameter if we did not receive an appointment date and time. Fatal case to this message. "RTN","SDCCRSEN",129,0) ;BASEDT (O,REQ) - appointment base date/time to use. May be incremented later if processing multiple joint clinic scheduling "RTN","SDCCRSEN",130,0) N ORDIDTYP,SRVNAME,CONSULTID "RTN","SDCCRSEN",131,0) D PARSESEG^SDCCRSCU(SCH,.SCH) "RTN","SDCCRSEN",132,0) S MSGARY("PLACER ID")=$G(SCH(1)) ;SCH-1.1 "RTN","SDCCRSEN",133,0) ;Cancel Reason "RTN","SDCCRSEN",134,0) S CONID=$G(SCH(2)),PROVIDER=$G(SCH(12,1,2))_" "_$G(SCH(12,1,3)) "RTN","SDCCRSEN",135,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",136,0) I $G(MSGARY("CANCEL REASON"))'="" N CANRSN S CANRSN=$O(^SD(409.2,"B",$G(MSGARY("CANCEL REASON")),"")) I CANRSN="" S MSGARY("CANCEL REASON")=11 "RTN","SDCCRSEN",137,0) ;Duration "RTN","SDCCRSEN",138,0) S (SDECLEN,MSGARY("DURATION"))=$G(SCH(9)) ;SCH-9,10 "RTN","SDCCRSEN",139,0) ;Appointment Date "RTN","SDCCRSEN",140,0) N Y "RTN","SDCCRSEN",141,0) S (SDECSTART,BASEDT)=$$HL7TFM^XLFDT($G(SCH(11,1,4)),"L") ;SCH-11.3 "RTN","SDCCRSEN",142,0) S APTTM=$G(SCH(11,1,4)) "RTN","SDCCRSEN",143,0) N Y S SDECEND=$$HL7TFM^XLFDT($G(SCH(11,1,5)),"L") ;SCH-11.3 "RTN","SDCCRSEN",144,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",145,0) ;User "RTN","SDCCRSEN",146,0) S (MSGARY("USER"))=$$GETUSER($G(SCH(20,1,1))) ;SCH-20 "RTN","SDCCRSEN",147,0) S USERMAIL=$$LOW^XLFSTR($G(SCH(13,1,4))) S:$G(USERMAIL)'="" DUZ=$O(^VA(200,"ADUPN",$G(USERMAIL),"")) "RTN","SDCCRSEN",148,0) S:$G(DUZ)'>0 DUZ=$O(^VA(200,"ADUPN",$E(USERMAIL,1,30),"")) ;29 JAN 2020 - PB - Change for patch 735 to look emails longer than 30 characters "RTN","SDCCRSEN",149,0) I $G(DUZ)'>0 S:$G(USERMAIL)'="" DUZ=$O(^VA(200,"ADUPN",$$UP^XLFSTR(USERMAIL),"")) "RTN","SDCCRSEN",150,0) I DUZ'>0 S DUZ=.5,(NAKMSG,ERR1)="SCHEDULER DOESN'T HAVE AN ACCOUNT ON THIS SYSTEM",ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",151,0) S MSGARY("STATUS")=$$GETSTAT($G(SCH(25))) ;SCH-25 "RTN","SDCCRSEN",152,0) ; Linked Consults/Orders "RTN","SDCCRSEN",153,0) S ORDIDTYP=$$GET^SDCCRSCU(.SCH,27,2) ;Placer ID Type "RTN","SDCCRSEN",154,0) Q "RTN","SDCCRSEN",155,0) NTE(NTE,MSGARY,LASTSEG,CLINARY,ABORT,PROVDTL) ;NTE segment processing. "RTN","SDCCRSEN",156,0) ;NTE (I/REQ) - NTE message segment data "RTN","SDCCRSEN",157,0) ;MSGARY (I/O,REQ) - message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",158,0) ;LASTSEG (I,REQ) - segment previous to the NTE to determine context of note. "RTN","SDCCRSEN",159,0) ;CLINARY (I/O,REQ) - List of Clinics to be scheduled. Could contain more than one for joint appointments "RTN","SDCCRSEN",160,0) ;ABORT (O,REQ) - quit parameter to the whole tag. Having one clinic unmapped must stop filing. "RTN","SDCCRSEN",161,0) ;PROVDTL (I/OPT) - passed when NTE concerns a preceding AIP or AIG segment "RTN","SDCCRSEN",162,0) N NOTE,NOTETYPE,CLINIC "RTN","SDCCRSEN",163,0) S LASTSEG=$G(LASTSEG) "RTN","SDCCRSEN",164,0) S NOTE=$$GET^SDCCRSCU(.NTE,3,1) ;NTE-3.1 "RTN","SDCCRSEN",165,0) S NOTETYPE=$$GET^SDCCRSCU(.NTE,4,1) ;NTE-4.1 "RTN","SDCCRSEN",166,0) ;Process NTE following SCH for scheduling comments. "RTN","SDCCRSEN",167,0) S (SDECNOTE,NOTE)=$TR(NOTE,"^","?") ;JAN 21, 2020 - PB - adding SDECNOTE to have the booking notes "RTN","SDCCRSEN",168,0) I LASTSEG="SCH" D "RTN","SDCCRSEN",169,0) . I ($G(MSGARY("COMMENT"))'=""),(NOTE'="") S MSGARY("COMMENT")=$G(MSGARY("COMMENT"))_" " "RTN","SDCCRSEN",170,0) . S MSGARY("COMMENT")=NOTE "RTN","SDCCRSEN",171,0) Q "RTN","SDCCRSEN",172,0) PID(PID,MSGARY,ABORT) ;PID segment processing. "RTN","SDCCRSEN",173,0) ;PID (I/REQ) - PID message segment data "RTN","SDCCRSEN",174,0) ;MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",175,0) ;ABORT (O,OPT) - Error parameter if we failed to find a valid patient. Fatal case to this message. "RTN","SDCCRSEN",176,0) N IDENTIFIERS,IENCHECK,OK "RTN","SDCCRSEN",177,0) D PARSESEG^SDCCRSCU(PID,.PID) "RTN","SDCCRSEN",178,0) S ICN=$G(PID(3,1,1)),(SDDFN,DFN)=$$GETDFN^MPIF001($P(ICN,"V")) "RTN","SDCCRSEN",179,0) Q "RTN","SDCCRSEN",180,0) PV1(PV1,MSGARY,HDRTIME,ABORT) ;PV1 segment processing. "RTN","SDCCRSEN",181,0) ;PV1 (I/REQ) - PV1 message segment data "RTN","SDCCRSEN",182,0) ;MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",183,0) ;HDRTIME (I,OPT) - TIME FROM MSH-7, USED AS A DEFAULTING OPTION "RTN","SDCCRSEN",184,0) ;ABORT (O,OPT) - Error parameter if we failed to find a valid patient. Fatal case to this message. "RTN","SDCCRSEN",185,0) N ERROR "RTN","SDCCRSEN",186,0) D PARSESEG^SDCCRSCU(PV1,.PV1) "RTN","SDCCRSEN",187,0) I $G(PV1(19))'>0 S (NAKMSG,ERR1)="CONSULT ID MISSING. " D ACK^SDCCRCOR("CE",MID,"PV1","",19,305,ERR1,1) S ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",188,0) S CONSULTID=0,(CONID,CONSULTID)=$G(PV1(19)) "RTN","SDCCRSEN",189,0) S MSGARY("FILLER ID")=CONSULTID "RTN","SDCCRSEN",190,0) S SDAPTYP="C|"_$G(CONSULTID) "RTN","SDCCRSEN",191,0) N Y,RESNAME "RTN","SDCCRSEN",192,0) S CID=$$GET1^DIQ(123,$G(CONSULTID)_",",17,"E") S:$G(CID)'="" CID=$P($$FMTE^XLFDT(CID,1),"@",1) "RTN","SDCCRSEN",193,0) S SDECRESA=$$GET1^DIQ(123,$G(CONSULTID)_",",1,"I"),(CONTITLE,SRVNAME)=$$GET1^DIQ(123,$G(CONSULTID)_",",1,"E") "RTN","SDCCRSEN",194,0) I $G(SRVNAME)'["COMMUNITY CARE" S (NAKMSG,ERR1)="Not a Community Care Consult" D ACK^SDCCRCOR("CE",MID,"PV1",19,305,ERR1,1) S ABORT="2^"_ERR1 Q "RTN","SDCCRSEN",195,0) S SDCL=$$CHECKLST($G(SRVNAME)) "RTN","SDCCRSEN",196,0) I $G(SDCL)'>0 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",197,0) N SDRES S SDRES=$O(^SDEC(409.831,"B",$G(SRVNAMEX),"")) S:$G(SDRES)>0 SDECRES=$G(SDRES) "RTN","SDCCRSEN",198,0) I $G(SDECRES)="" S (NAKMSG,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",199,0) ;Need to check to see if the clinic is inactive - is there an SDEC API for this? "RTN","SDCCRSEN",200,0) ;I $$INACTIVE^SDEC32(SDCL) S (NAKMSG,ERR1)="Clinic "_$P(^SC(SDCL,0),"^")_" is inactive" D ACK^SDCCRCOR("CE",MID,"PV1","",19,305,ERR1,1) S ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",201,0) S MSGARY("CHECKINDT")=$$DETTIME($$GET^SDCCRSCU(.PV1,44,1),$G(HDRTIME),.ERROR) ;PV1-44.1 "RTN","SDCCRSEN",202,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",203,0) ;CHECK OUT DATE/TIME "RTN","SDCCRSEN",204,0) S MSGARY("CHECKOUTDT")=$$DETTIME($$GET^SDCCRSCU(.PV1,45,1),$G(HDRTIME),.ERROR) ;PV1-45.1 "RTN","SDCCRSEN",205,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",206,0) Q "RTN","SDCCRSEN",207,0) RGS(RGS,MSGARY) ; RGS segment processing. "RTN","SDCCRSEN",208,0) ;Per HL7 this segment repeats and has multiple AIS/AIG/AIP segments underneath. "RTN","SDCCRSEN",209,0) ;RGS (I/REQ) - RGS message segment data "RTN","SDCCRSEN",210,0) ; MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",211,0) Q "RTN","SDCCRSEN",212,0) AIS(AIS,MSGARY) ;AIS segment processing. "RTN","SDCCRSEN",213,0) ;Per HL7 this field can repeat within each RGS group. "RTN","SDCCRSEN",214,0) ;AIS (I/REQ) - AIS message segment data "RTN","SDCCRSEN",215,0) ;MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",216,0) Q "RTN","SDCCRSEN",217,0) AIP(AIP,MSGARY,PROVDTL,BASEDTE) ;AIP segment processing. "RTN","SDCCRSEN",218,0) ;Per HL7 this field can repeat within each RGS group. "RTN","SDCCRSEN",219,0) ;AIP (I/REQ) - AIP message segment data "RTN","SDCCRSEN",220,0) ;MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",221,0) ;PROVDTL (O,REQ) - AIP date/time and length "RTN","SDCCRSEN",222,0) ;BASEDTE (I,REQ) - Appt D/T from SCH "RTN","SDCCRSEN",223,0) D PARSESEG^SDCCRSCU(AIP,.AIP) "RTN","SDCCRSEN",224,0) S PROV=$G(AIP(3,1,2))_" "_$G(AIP(3,1,3)) "RTN","SDCCRSEN",225,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",226,0) ;E S PROVDTL("DT")=BASEDTE "RTN","SDCCRSEN",227,0) ;S PROVDTL("LN")=MSGARY("DURATION") "RTN","SDCCRSEN",228,0) Q "RTN","SDCCRSEN",229,0) ; "RTN","SDCCRSEN",230,0) AIL(AIL,RETVAL) ; Process AIL Segment "RTN","SDCCRSEN",231,0) ;D PARSESEG^SDCCRSCU(AIP,.AIP) "RTN","SDCCRSEN",232,0) ;S LOC=$G(AIP(4,1,2)) "RTN","SDCCRSEN",233,0) Q "RTN","SDCCRSEN",234,0) AIG(AIG,MSGARY,PROVDTL,BASEDTE) ;AIG segment processing. "RTN","SDCCRSEN",235,0) ;Per HL7 this field can repeat within each RGS group. "RTN","SDCCRSEN",236,0) ;AIG (I/REQ) - AIG message segment data "RTN","SDCCRSEN",237,0) ;MSGARY (I/O,REQ) message array structure with unformatted and translated data ready for filing. See PARSEMSG for details. "RTN","SDCCRSEN",238,0) ;PROVDTL (O,REQ) - AIG date/time and length "RTN","SDCCRSEN",239,0) ;BASEDTE (I,REQ) - Appt D/T from SCH "RTN","SDCCRSEN",240,0) D PARSESEG^SDCCRSCU(AIG,.AIG) "RTN","SDCCRSEN",241,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",242,0) E S PROVDTL("DT")=BASEDTE "RTN","SDCCRSEN",243,0) S PROVDTL("LN")=MSGARY("DURATION") "RTN","SDCCRSEN",244,0) Q "RTN","SDCCRSEN",245,0) ; "RTN","SDCCRSEN",246,0) GETRSN(SCH) ; Collects appointment reason and translates into internal format. "RTN","SDCCRSEN",247,0) ;Tries using the Title to lookup the reason. If that fails uses the ID to lookup "RTN","SDCCRSEN",248,0) ;the reason against the title. If that fails tries using the ID against the ID. "RTN","SDCCRSEN",249,0) ;SCH (I/REQ) - SCH message segment data "RTN","SDCCRSEN",250,0) Q $$DATALKUP^SDCCRCOR(.SCH,"409.2","^SD(409.2,",6,302,"APPOINTMENT REASON MAPPING ERROR") "RTN","SDCCRSEN",251,0) GETTYPE(OBX) ;translates appointment type into internal format "RTN","SDCCRSEN",252,0) ;OBX (I/REQ) - OBX message segment data "RTN","SDCCRSEN",253,0) N APPTTYPE "RTN","SDCCRSEN",254,0) S APPTTYPE=$$DATALKUP^SDCCRCOR(.OBX,"409.1","^SD(409.1,",5,303,"APPOINTMENT TYPE MAPPING ERROR") "RTN","SDCCRSEN",255,0) I $G(APPTTYPE)="" S APPTTYPE=9 "RTN","SDCCRSEN",256,0) Q APPTTYPE "RTN","SDCCRSEN",257,0) ; "RTN","SDCCRSEN",258,0) GETUSER(SCH) ;collects appointment entered by user and confirms they are a user in the 200 file "RTN","SDCCRSEN",259,0) ;SCH (I/REQ) - SCH message segment data "RTN","SDCCRSEN",260,0) Q:$G(SCH)="" "RTN","SDCCRSEN",261,0) S USER=$$FIND1^DIC(200,,"X",$G(SCH),"ASECID",,"SCERR") "RTN","SDCCRSEN",262,0) S USER=.5 "RTN","SDCCRSEN",263,0) Q USER "RTN","SDCCRSEN",264,0) GETSTAT(SCH) ; Translates status into appropriate scheduling statuses "RTN","SDCCRSEN",265,0) ;Options: (SCHEDULED,CHECKED IN,CHECKED OUT,CANCELLED,NO SHOW) "RTN","SDCCRSEN",266,0) ;SCH (I/REQ) - SCH message segment data "RTN","SDCCRSEN",267,0) N STATUS,ID,TITLE "RTN","SDCCRSEN",268,0) S ID=$$GET^SDCCRSCU(.SCH,25,1) "RTN","SDCCRSEN",269,0) S TITLE=$$GET^SDCCRSCU(.SCH,25,2) "RTN","SDCCRSEN",270,0) I $$INSTRING^SDCCRCOR(TITLE,"SCHEDULED,CHECKED IN,CHECKED OUT,CANCELLED,NO SHOW") Q TITLE "RTN","SDCCRSEN",271,0) I $$INSTRING^SDCCRCOR(ID,"SCHEDULED,CHECKED IN,CHECKED OUT,CANCELLED,NO SHOW") Q ID "RTN","SDCCRSEN",272,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",273,0) Q "NA" "RTN","SDCCRSEN",274,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",275,0) ;PID (I,REQ) - PID message segment data "RTN","SDCCRSEN",276,0) ;IDENTIFIERS (O,REQ) - Identifier array to return "RTN","SDCCRSEN",277,0) K IDS ;force output parameter "RTN","SDCCRSEN",278,0) N REP,ID,ASSIGN,IDTYPE "RTN","SDCCRSEN",279,0) S ID=PID(3,1,5) "RTN","SDCCRSEN",280,0) S IDENTIFIERS("PATIENT IEN")=$G(PID(3,2,1)) ;DFN "RTN","SDCCRSEN",281,0) S IDENTIFIERS("PATIENT ICN")=$G(PID(3,1,1)) ;ICN "RTN","SDCCRSEN",282,0) Q "RTN","SDCCRSEN",283,0) DETTIME(PV1TIME,HDRTIME,ERROR) ;RETURNS THE BEST CHECK IN/OUT TIME AVAILABLE IN THE MESSAGE OR DEFAULTS TO NOW "RTN","SDCCRSEN",284,0) ;PV1TIME (I,OPT) - HIGHEST PRIORITY TIME TO RETURN FROM EITHER PV1-44 OR PV1-45 "RTN","SDCCRSEN",285,0) ;HDRTIME (I,OPT) - TIME FROM MSH-7 "RTN","SDCCRSEN",286,0) ;ERROR (O,OPT) - ERROR OUTPUT PARAMETER "RTN","SDCCRSEN",287,0) K ERROR "RTN","SDCCRSEN",288,0) I $G(PV1TIME)'="" Q $$HL7TFM^XLFDT(PV1TIME,"L") "RTN","SDCCRSEN",289,0) I $G(HDRTIME)'="" S ERROR="FALLING BACK TO MSH-7" Q $$HL7TFM^XLFDT(HDRTIME,"L") "RTN","SDCCRSEN",290,0) S ERROR="FALLING BACK TO FILING TIME" "RTN","SDCCRSEN",291,0) Q $$NOW^XLFDT() "RTN","SDCCRSEN",292,0) CHECKLST(SRVNAME) ; "RTN","SDCCRSEN",293,0) ; lookup matching clinic for imaging comm care consults "RTN","SDCCRSEN",294,0) I $G(SRVNAME)="" Q 0 "RTN","SDCCRSEN",295,0) N CLINID,CLINIC,CONTITLE,LEN,I,XC "RTN","SDCCRSEN",296,0) S CLINID=0 "RTN","SDCCRSEN",297,0) S:$G(SRVNAME)[" - " SRVNAME=$P(SRVNAME," - ",1)_"-"_$P(SRVNAME," - ",2) "RTN","SDCCRSEN",298,0) S:$G(SRVNAME)[" -" SRVNAME=$P(SRVNAME," -",1)_"-"_$P(SRVNAME," -",2) "RTN","SDCCRSEN",299,0) S:$G(SRVNAME)["- " SRVNAME=$P(SRVNAME,"- ",1)_"-"_$P(SRVNAME,"- ",2) "RTN","SDCCRSEN",300,0) S LEN=$L(SRVNAME),XC=1 "RTN","SDCCRSEN",301,0) F I=0:1:LEN I $E(SRVNAME,I)="-" S XC=XC+1 "RTN","SDCCRSEN",302,0) S CONTITLE=SRVNAME "RTN","SDCCRSEN",303,0) S (RSNAME,SRVNAME)="COM CARE-"_$P(SRVNAME,"-",2,XC),SRVNAME=$E(SRVNAME,1,30) S:$E(SRVNAME,30)=" " SRVNAME=$E(SRVNAME,1,29) "RTN","SDCCRSEN",304,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",305,0) S:$E($P(RSNAME,"-",2),1,3)="DOD" (RSNAME,SRVNAME)="CC-"_$P(RSNAME,"-",2,XC) "RTN","SDCCRSEN",306,0) S CLINID=$O(^SC("B",$E($G(SRVNAME),1,30),"")) "RTN","SDCCRSEN",307,0) I $G(CLINID)'>0 D "RTN","SDCCRSEN",308,0) .F I=1:1:20 D "RTN","SDCCRSEN",309,0) ..Q:$G(CLINID)>0 "RTN","SDCCRSEN",310,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",311,0) I CLINID'>0 D "RTN","SDCCRSEN",312,0) . N LENG,SRVNAME1 "RTN","SDCCRSEN",313,0) . S LENG=0 "RTN","SDCCRSEN",314,0) . S LENG=$L(SRVNAME) "RTN","SDCCRSEN",315,0) . S (SRVNAME,SRVNAME1)=$S(LENG>28:$E(SRVNAME,1,28)_"-X",1:$G(SRVNAME)_"-X"),CLINID=$O(^SC("B",$G(SRVNAME1),"")) "RTN","SDCCRSEN",316,0) S SRVNAMEX=SRVNAME "RTN","SDCCRSEN",317,0) ;Need to check to see if the clinic is inactive - is there an SDEC API for this? "RTN","SDCCRSEN",318,0) N INACT S:$G(CLINID)>0 INACT=$$INACTIVE^SDEC32(CLINID) ; S (NAKMSG,ERR1)="Clinic "_$P(^SC(SDCL,0),"^")_" is inactive" D ACK^SDCCRCOR("CE",MID,"PV1","",19,305,ERR1,1) S ABORT="1^"_ERR1 Q "RTN","SDCCRSEN",319,0) I CLINID'>0!$G(INACT)=1 S CLINID=$O(^SC("B","COM CARE-OTHER","")) S:$G(CLINID)>0 (SRVNAMEX,SRVNAME)=$P(^SC(CLINID,0),"^") S:$G(CLINID)'>0 (SRVNAMEX,SRVNAME)="COM CARE-OTHER" "RTN","SDCCRSEN",320,0) Q CLINID "RTN","SDCCRSEN",321,0) LIST ; List of Imaging Community Care consult titles and clinics "RTN","SDCCRSEN",322,0) ;;COMMUNITY CARE-IMAGING CT-AUTO^COM CARE-IMAG CT-AUTO "RTN","SDCCRSEN",323,0) ;;COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO^COM CARE-IMAG GEN RAD-AUTO "RTN","SDCCRSEN",324,0) ;;COMMUNITY CARE-IMAGING MAGNETIC RESONANCE IMAGING-AUTO^COM CARE-IMAG MRI-AUTO "RTN","SDCCRSEN",325,0) ;;COMMUNITY CARE-IMAGING MAMMOGRAPHY DIAGNOSTIC-AUTO^COM CARE-IMAG MAM DIAG-AUTO "RTN","SDCCRSEN",326,0) ;;COMMUNITY CARE-IMAGING MAMMOGRAPHY SCREEN-AUTO^COM CARE-IMAG MAM SCR-AUTO "RTN","SDCCRSEN",327,0) ;;COMMUNITY CARE-IMAGING NUCLEAR MEDICINE-AUTO^COM CARE-IMAG NUC MEC-AUTO "RTN","SDCCRSEN",328,0) ;;COMMUNITY CARE-IMAGING ULTRASOUND-AUTO^COM CARE-IMAG U/S-AUTO "RTN","SDCCRSEN",329,0) ;;COMMUNITY CARE-CIH BIOFEEDBACK/NEUROFEEDBACK^COM CARE-CIH BIO/NEURO FB "RTN","SDCCRSEN",330,0) ;;COMMUNITY CARE-CIH CLINICAL/BEHAVIORAL HYPNOTHERAPY^COM CARE-CIH CLIN/BEH HYPNO "RTN","SDCCRSEN",331,0) ;;COMMUNITY CARE-EMERGENCY TREATMENT APPROVED^COM CARE-EMER TREAT APPR "RTN","SDCCRSEN",332,0) ;;COMMUNITY CARE-INFERTILITY EVAL ONLY^COM CARE-INFERTILITY EVAL "RTN","SDCCRSEN",333,0) ;;COMMUNITY CARE-GEC ADULT DAY HEALTH CARE^COM CARE-GEC ADHC "RTN","SDCCRSEN",334,0) ;;COMMUNITY CARE-GEC NON-SKILLED HOME HEALTH AIDE^COM CARE-GEC NON-SK HHA "RTN","SDCCRSEN",335,0) ;;COMMUNITY CARE-IMAGING CT COLONOGRAPHY^COM CARE-IMAG CT COLON "RTN","SDCCRSEN",336,0) ;;COMMUNITY CARE-IMAGING BARIUM ENEMA^COM CARE-IMAG BARIUM ENEMA "RTN","SDCCRSEN",337,0) ;;COMMUNITY CARE-HOME SLEEP APNEA TEST^COM CARE-HOME SLEEP APNEA "RTN","SDCCRSEN",338,0) ;;COMMUNITY CARE-PTSD CLINICAL DEMONSTRATION (HBOT)^COM CARE-PTSD CL DEMO (HBOT) "RTN","SDCCRSEN",339,0) ;;COMMUNITY CARE-TREATMENT RESISTANT DEPRESSION^COM CARE-TRT RESIST DEP "RTN","SDCCRSEN",340,0) ;;COMMUNITY CARE-HEMATOLOGY/ONCOLOGY^COM CARE-HEMATOLOGY/ONCOLOGY "RTN","SDCCRSEN",341,0) ;;COMMUNITY CARE-HARDSHIP DETERMINATION^COM CARE-HARDSHIP DETER "RTN","SDPST735") 0^4^B3238326^n/a "RTN","SDPST735",1,0) SDPST735 ;;CCRA/PB - CCRA PRE INSTALL;NOV 4, 2019 "RTN","SDPST735",2,0) ;;5.3;Scheduling;**735**;NOV 4, 2019;Build 21 "RTN","SDPST735",3,0) ;;Per VA directive 6402, this routine should not be modified. "RTN","SDPST735",4,0) ;Post install routine for patch SD*5.3*735. "RTN","SDPST735",5,0) ;Checks for the CCRA-NAK logical link, if it exists, edits the link to remove "RTN","SDPST735",6,0) ;the institution and adds the COM CARE-OTHER non count clinic to the "RTN","SDPST735",7,0) ;Hospital Location File (#44) "RTN","SDPST735",8,0) Q "RTN","SDPST735",9,0) EN ; Entry point "RTN","SDPST735",10,0) ;D CLINIC "RTN","SDPST735",11,0) LINK ; update the CCRA-NAK Link "RTN","SDPST735",12,0) N LIEN,VAL,SDERR,FDA,DNS "RTN","SDPST735",13,0) D MES^XPDUTL("Checking VistA system for CCRA-NAK logical link setup...") "RTN","SDPST735",14,0) S VAL="CCRA-NAK" "RTN","SDPST735",15,0) S LIEN=$$FIND1^DIC(870,,"B",.VAL) "RTN","SDPST735",16,0) I $G(LIEN)'>0 D MES^XPDUTL("Link doesn't exists") Q "RTN","SDPST735",17,0) S DNS=$$GET1^DIQ(870,$G(LIEN)_",",400.01,"I") "RTN","SDPST735",18,0) D MES^XPDUTL("") "RTN","SDPST735",19,0) D MES^XPDUTL("") "RTN","SDPST735",20,0) D MES^XPDUTL("") "RTN","SDPST735",21,0) D MES^XPDUTL("CCRA-NAK logical link being set up now. ") "RTN","SDPST735",22,0) D MES^XPDUTL("") "RTN","SDPST735",23,0) D MES^XPDUTL("") "RTN","SDPST735",24,0) D MES^XPDUTL("") "RTN","SDPST735",25,0) ; "RTN","SDPST735",26,0) ; file link with IP address and port entered "RTN","SDPST735",27,0) K FDA,SDERR "RTN","SDPST735",28,0) S FDA(870,$G(LIEN)_",",.02)="@" ; delete the station number "RTN","SDPST735",29,0) S FDA(870,$G(LIEN)_",",.08)=$G(DNS) ; add dns domain for HealthConnect server "RTN","SDPST735",30,0) D UPDATE^DIE(,"FDA",$G(LIEN)_",","SDERR") K FDA "RTN","SDPST735",31,0) D MES^XPDUTL("") "RTN","SDPST735",32,0) I $D(SDERR) D Q ; something went wrong "RTN","SDPST735",33,0) .D MES^XPDUTL("FileMan error when editing the CCCRA-NAK Link.") "RTN","SDPST735",34,0) D MES^XPDUTL("CCRA-NAK Link has been updated.") "RTN","SDPST735",35,0) Q "RTN","SDPST735",36,0) QEND K DIR,SDERR Q "RTN","SDPST735",37,0) QABORT S XPDABORT=1 K DIR,SDERR Q "VER") 8.0^22.2 "BLD",11450,6) ^604 **END** **END**