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

SDEC671.m

Go to the documentation of this file.
  1. SDEC671 ;OAK/MKO-POST INSTALL FOR SD*5.3*671 ;12:33 PM 23 Jun 2017
  1. ;;5.3;Scheduling;**671**;Aug 13, 1993;Build 25
  1. Q
  1. ;
  1. POST ;Entry point for Post InstalL
  1. D ADDPROT
  1. D TRANSFER
  1. D POST2
  1. Q
  1. ;
  1. ADDPROT ;Link OR and SD protocols
  1. N RET
  1. D BMES^XPDUTL("Adding Protocol 'OR RECEIVE' to the protocol 'SD EVSEND OR'.")
  1. S RET=$$ADD^XPDPROT("SD EVSEND OR","OR RECEIVE","",1)
  1. D:'RET MES^XPDUTL("ERROR: "_$P(RET,"^",2)_" **")
  1. ;
  1. D BMES^XPDUTL("Adding Protocol 'OCX ORDER CHECK HL7 RECIEVE' to the protocol 'SD EVSEND OR'.")
  1. S RET=$$ADD^XPDPROT("SD EVSEND OR","OCX ORDER CHECK HL7 RECIEVE","",1)
  1. D:'RET MES^XPDUTL("ERROR: "_$P(RET,"^",2)_" **")
  1. ;
  1. I $$PATCH^XPDUTL("OR*3.0*434") D
  1. .D BMES^XPDUTL("Adding Protocol 'SD RECEIVE OR' to the protocol 'OR EVSEND SD'.")
  1. .S RET=$$ADD^XPDPROT("OR EVSEND SD","SD RECEIVE OR","",1)
  1. .D:'RET MES^XPDUTL("ERROR: "_$P(RET,"^",2)_" **")
  1. Q
  1. ;
  1. TRANSFER ;Copy data from File #409.85 to #409.86
  1. N PATCH,STUS
  1. S PATCH=$O(^XPD(9.7,"B","SD*5.3*671",""),-1) I PATCH>0 D
  1. .S STUS=$$GET1^DIQ(9,7,PATCH,.02,"I")
  1. .I STUS=3 D BMES^XPDUTL("POST-INIT routine has already run!")
  1. Q:$G(STUS)=3
  1. I $G(^XTMP("SDEC671")) D
  1. .D BMES^XPDUTL("POST-INIT routine already started, PLEASE refer to patch instructions to restart!")
  1. Q:$G(^XTMP("SDEC671"))
  1. N CA85,CDT85,CLM85,CN85,CR85,CU85,DFN85
  1. S ^XTMP("SDEC671")=""
  1. ;
  1. ;Loop through entries in file #409.85
  1. S DFN85=0 F S DFN85=$O(^SDEC(409.85,"B",DFN85)) Q:DFN85'>0 D
  1. .S IEN85="" F S IEN85=$O(^SDEC(409.85,"B",DFN85,IEN85)) Q:IEN85="" D
  1. ..N FDA,SEQ,MSG,DIERR,DIMSG,R85
  1. ..S R85=$G(^SDEC(409.85,IEN85,0)) Q:R85=""
  1. ..Q:$P($G(R85),"^",17)'="O" ;Current status (#23)
  1. ..Q:DFN85'=$P(R85,"^")
  1. ..Q:$O(^SDEC(409.85,IEN85,4,0))'>0 ;Patient contact multiple (#44)
  1. ..;
  1. ..;Set FDA for top level fields of File #409.86
  1. ..S FDA(409.86,"+1,",.01)=DFN85 ;Patient
  1. ..S FDA(409.86,"+1,",1)=$P(R85,"^",9) ;Req specific clinic (#8,P44) -> Clinic
  1. ..S FDA(409.86,"+1,",2)=$P(R85,"^",16) ;CID/Preferred Date of Appt (#22) -> Preferred date
  1. ..S FDA(409.86,"+1,",2.1)=$P(R85,"^",5) ;Request type (#4) -> Request type
  1. ..S FDA(409.86,"+1,",2.2)=1 ;Sequence
  1. ..S FDA(409.86,"+1,",1.1)=$P(R85,"^",4) ;Req service/specialty (#8.5,P40.7) -> Service
  1. ..;
  1. ..;Loop through PATIENT CONTACT multiple (#44) of File #409.85 and set FDA array
  1. ..;for the DATE/TIME of CONTACT multiple (#3) of File #409.86
  1. ..S SEQ=1
  1. ..S CN85="" F S CN85=$O(^SDEC(409.85,IEN85,4,CN85)) Q:CN85'>0 D
  1. ...S CR85=$G(^SDEC(409.85,IEN85,4,CN85,0)) Q:CR85=""
  1. ...S CDT85=$P(CR85,"^") Q:CDT85="" ;Date entered (#.01)
  1. ...S CU85=$P(CR85,"^",2) Q:CU85="" ;Entered by user (#2,P200)
  1. ...S CA85=$P(CR85,"^",3) Q:CA85="" ;Action (#3)
  1. ...S CLM85="" I CA85="M" S CA85="C",CLM85=1
  1. ...;
  1. ...S SEQ=SEQ+1
  1. ...S IENS="+"_SEQ_",+1,"
  1. ...S FDA(409.863,IENS,.01)=$P(CR85,"^")
  1. ...S FDA(409.863,IENS,1)=CA85 ;Contact type
  1. ...S:SEQ=2 FDA(409.863,IENS,2)=$P(R85,"^",18) ;Comments from top level #409.85,25 -> Comments
  1. ...S FDA(409.863,IENS,3)=CLM85 ;Left message
  1. ...S FDA(409.863,IENS,4)=SEQ-1 ;Sequence
  1. ...S FDA(409.863,IENS,5)=CU85 ;User entered contact
  1. ...S FDA(409.863,IENS,6)=CDT85 ;Date/time entered
  1. ..;
  1. ..S ^XTMP("SDEC671")=DFN85_"^"_IEN85
  1. ..D UPDATE^DIE("","FDA","","MSG")
  1. Q
  1. ;
  1. RESTART ;Copy data from File #409.85 to #409.86
  1. N CA85,CDT85,CLM85,CN85,CR85,CU85,DFN85
  1. ;
  1. ;Loop through entries in file #409.85
  1. I '$G(^XTMP("SDEC671")) S $P(^XTMP("SDEC671"),"^",1)=0
  1. S DFN85=$P(^XTMP("SDEC671"),"^",1) F S DFN85=$O(^SDEC(409.85,"B",DFN85)) Q:DFN85'>0 D
  1. .S IEN85="" F S IEN85=$O(^SDEC(409.85,"B",DFN85,IEN85)) Q:IEN85="" D
  1. ..N FDA,SEQ,MSG,DIERR,DIMSG,R85
  1. ..S R85=$G(^SDEC(409.85,IEN85,0)) Q:R85=""
  1. ..Q:$P($G(R85),"^",17)'="O" ;Current status (#23)
  1. ..Q:DFN85'=$P(R85,"^")
  1. ..Q:$O(^SDEC(409.85,IEN85,4,0))'>0 ;Patient contact multiple (#44)
  1. ..;
  1. ..;Set FDA for top level fields of File #409.86
  1. ..S FDA(409.86,"+1,",.01)=DFN85 ;Patient
  1. ..S FDA(409.86,"+1,",1)=$P(R85,"^",9) ;Req specific clinic (#8,P44) -> Clinic
  1. ..S FDA(409.86,"+1,",2)=$P(R85,"^",16) ;CID/Preferred Date of Appt (#22) -> Preferred date
  1. ..S FDA(409.86,"+1,",2.1)=$P(R85,"^",5) ;Request type (#4) -> Request type
  1. ..S FDA(409.86,"+1,",2.2)=1 ;Sequence
  1. ..S FDA(409.86,"+1,",1.1)=$P(R85,"^",4) ;Req service/specialty (#8.5,P40.7) -> Service
  1. ..;
  1. ..;Loop through PATIENT CONTACT multiple (#44) of File #409.85 and set FDA array
  1. ..;for the DATE/TIME of CONTACT multiple (#3) of File #409.86
  1. ..S SEQ=1
  1. ..S CN85="" F S CN85=$O(^SDEC(409.85,IEN85,4,CN85)) Q:CN85'>0 D
  1. ...S CR85=$G(^SDEC(409.85,IEN85,4,CN85,0)) Q:CR85=""
  1. ...S CDT85=$P(CR85,"^") Q:CDT85="" ;Date entered (#.01)
  1. ...S CU85=$P(CR85,"^",2) Q:CU85="" ;Entered by user (#2,P200)
  1. ...S CA85=$P(CR85,"^",3) Q:CA85="" ;Action (#3)
  1. ...S CLM85="" I CA85="M" S CA85="C",CLM85=1
  1. ...;
  1. ...S SEQ=SEQ+1
  1. ...S IENS="+"_SEQ_",+1,"
  1. ...S FDA(409.863,IENS,.01)=$P(CR85,"^")
  1. ...S FDA(409.863,IENS,1)=CA85 ;Contact type
  1. ...S:SEQ=2 FDA(409.863,IENS,2)=$P(R85,"^",18) ;Comments from top level #409.85,25 -> Comments
  1. ...S FDA(409.863,IENS,3)=CLM85 ;Left message
  1. ...S FDA(409.863,IENS,4)=SEQ-1 ;Sequence
  1. ...S FDA(409.863,IENS,5)=CU85 ;User entered contact
  1. ...S FDA(409.863,IENS,6)=CDT85 ;Date/time entered
  1. ..;
  1. ..S ^XTMP("SDEC671")=DFN85_"^"_IEN85
  1. ..D UPDATE^DIE("","FDA","","MSG")
  1. Q
  1. ;
  1. POST2 ;
  1. N PAT84,ST84,APP84,IEN84,CL84P,CL84,DFN84,PAT0,STA
  1. S J=0
  1. ;
  1. S ADT84="" F S ADT84=$O(^SDEC(409.84,"B",ADT84)) Q:ADT84'>0 D
  1. .S IEN84="" F S IEN84=$O(^SDEC(409.84,"B",ADT84,IEN84)) Q:IEN84="" D
  1. ..S PAT84="" S PAT84=^SDEC(409.84,IEN84,0) Q:PAT84=""
  1. ..Q:$P($G(PAT84),"^",5)=""
  1. ..Q:$P($G(PAT84),"^",3)'="" ;Quit if cancel d/t entered
  1. ..Q:$P($G(PAT84),"^",4)'=""
  1. ..Q:$P($G(PAT84),"^",12)'=""
  1. ..Q:$P($G(PAT84),"^",14)'="" ;Quit if checkout d/t entered
  1. ..S ST84="" S ST84=$P($G(PAT84),"^",17)
  1. ..S DFN84="" S DFN84=$P($G(PAT84),"^",5) Q:DFN84=""
  1. ..S CL84P="" S CL84P=$P($G(PAT84),"^",7) Q:CL84P=""
  1. ..S CL84="" S CL84=$$GET1^DIQ(409.831,CL84P,.04,"I") Q:CL84=""
  1. ..S PAT0="" S PAT0=$G(^DPT(DFN84,0)) Q:PAT0=""
  1. ..S STA="" S STA=$$STATUS^SDAM1(DFN84,ADT84,CL84,PAT0)
  1. ..I ($P(STA,";",1)=11)!($P(STA,";",1)=3) D DEL
  1. ..Q
  1. Q
  1. ;
  1. DEL ;
  1. N REC2
  1. S REC2=$G(^DPT(DFN84,"S",ADT84,0))
  1. Q:$P(REC2,"^",1)=CL84
  1. W !,IEN84_" "_ADT84_" "_$P(^DPT(DFN84,0),"^",1)
  1. S J=J+1 S ^XTMP("673SDEC",J)=IEN84_" "_ADT84_" "_$P(^DPT(DFN84,0),"^",1)
  1. S DIK="^SDEC(409.84,",DA=IEN84 D ^DIK
  1. Q