- SDEC671 ;OAK/MKO-POST INSTALL FOR SD*5.3*671 ;12:33 PM 23 Jun 2017
- ;;5.3;Scheduling;**671**;Aug 13, 1993;Build 25
- Q
- ;
- POST ;Entry point for Post InstalL
- D ADDPROT
- D TRANSFER
- D POST2
- Q
- ;
- ADDPROT ;Link OR and SD protocols
- N RET
- D BMES^XPDUTL("Adding Protocol 'OR RECEIVE' to the protocol 'SD EVSEND OR'.")
- S RET=$$ADD^XPDPROT("SD EVSEND OR","OR RECEIVE","",1)
- D:'RET MES^XPDUTL("ERROR: "_$P(RET,"^",2)_" **")
- ;
- D BMES^XPDUTL("Adding Protocol 'OCX ORDER CHECK HL7 RECIEVE' to the protocol 'SD EVSEND OR'.")
- S RET=$$ADD^XPDPROT("SD EVSEND OR","OCX ORDER CHECK HL7 RECIEVE","",1)
- D:'RET MES^XPDUTL("ERROR: "_$P(RET,"^",2)_" **")
- ;
- I $$PATCH^XPDUTL("OR*3.0*434") D
- .D BMES^XPDUTL("Adding Protocol 'SD RECEIVE OR' to the protocol 'OR EVSEND SD'.")
- .S RET=$$ADD^XPDPROT("OR EVSEND SD","SD RECEIVE OR","",1)
- .D:'RET MES^XPDUTL("ERROR: "_$P(RET,"^",2)_" **")
- Q
- ;
- TRANSFER ;Copy data from File #409.85 to #409.86
- N PATCH,STUS
- S PATCH=$O(^XPD(9.7,"B","SD*5.3*671",""),-1) I PATCH>0 D
- .S STUS=$$GET1^DIQ(9,7,PATCH,.02,"I")
- .I STUS=3 D BMES^XPDUTL("POST-INIT routine has already run!")
- Q:$G(STUS)=3
- I $G(^XTMP("SDEC671")) D
- .D BMES^XPDUTL("POST-INIT routine already started, PLEASE refer to patch instructions to restart!")
- Q:$G(^XTMP("SDEC671"))
- N CA85,CDT85,CLM85,CN85,CR85,CU85,DFN85
- S ^XTMP("SDEC671")=""
- ;
- ;Loop through entries in file #409.85
- S DFN85=0 F S DFN85=$O(^SDEC(409.85,"B",DFN85)) Q:DFN85'>0 D
- .S IEN85="" F S IEN85=$O(^SDEC(409.85,"B",DFN85,IEN85)) Q:IEN85="" D
- ..N FDA,SEQ,MSG,DIERR,DIMSG,R85
- ..S R85=$G(^SDEC(409.85,IEN85,0)) Q:R85=""
- ..Q:$P($G(R85),"^",17)'="O" ;Current status (#23)
- ..Q:DFN85'=$P(R85,"^")
- ..Q:$O(^SDEC(409.85,IEN85,4,0))'>0 ;Patient contact multiple (#44)
- ..;
- ..;Set FDA for top level fields of File #409.86
- ..S FDA(409.86,"+1,",.01)=DFN85 ;Patient
- ..S FDA(409.86,"+1,",1)=$P(R85,"^",9) ;Req specific clinic (#8,P44) -> Clinic
- ..S FDA(409.86,"+1,",2)=$P(R85,"^",16) ;CID/Preferred Date of Appt (#22) -> Preferred date
- ..S FDA(409.86,"+1,",2.1)=$P(R85,"^",5) ;Request type (#4) -> Request type
- ..S FDA(409.86,"+1,",2.2)=1 ;Sequence
- ..S FDA(409.86,"+1,",1.1)=$P(R85,"^",4) ;Req service/specialty (#8.5,P40.7) -> Service
- ..;
- ..;Loop through PATIENT CONTACT multiple (#44) of File #409.85 and set FDA array
- ..;for the DATE/TIME of CONTACT multiple (#3) of File #409.86
- ..S SEQ=1
- ..S CN85="" F S CN85=$O(^SDEC(409.85,IEN85,4,CN85)) Q:CN85'>0 D
- ...S CR85=$G(^SDEC(409.85,IEN85,4,CN85,0)) Q:CR85=""
- ...S CDT85=$P(CR85,"^") Q:CDT85="" ;Date entered (#.01)
- ...S CU85=$P(CR85,"^",2) Q:CU85="" ;Entered by user (#2,P200)
- ...S CA85=$P(CR85,"^",3) Q:CA85="" ;Action (#3)
- ...S CLM85="" I CA85="M" S CA85="C",CLM85=1
- ...;
- ...S SEQ=SEQ+1
- ...S IENS="+"_SEQ_",+1,"
- ...S FDA(409.863,IENS,.01)=$P(CR85,"^")
- ...S FDA(409.863,IENS,1)=CA85 ;Contact type
- ...S:SEQ=2 FDA(409.863,IENS,2)=$P(R85,"^",18) ;Comments from top level #409.85,25 -> Comments
- ...S FDA(409.863,IENS,3)=CLM85 ;Left message
- ...S FDA(409.863,IENS,4)=SEQ-1 ;Sequence
- ...S FDA(409.863,IENS,5)=CU85 ;User entered contact
- ...S FDA(409.863,IENS,6)=CDT85 ;Date/time entered
- ..;
- ..S ^XTMP("SDEC671")=DFN85_"^"_IEN85
- ..D UPDATE^DIE("","FDA","","MSG")
- Q
- ;
- RESTART ;Copy data from File #409.85 to #409.86
- N CA85,CDT85,CLM85,CN85,CR85,CU85,DFN85
- ;
- ;Loop through entries in file #409.85
- I '$G(^XTMP("SDEC671")) S $P(^XTMP("SDEC671"),"^",1)=0
- S DFN85=$P(^XTMP("SDEC671"),"^",1) F S DFN85=$O(^SDEC(409.85,"B",DFN85)) Q:DFN85'>0 D
- .S IEN85="" F S IEN85=$O(^SDEC(409.85,"B",DFN85,IEN85)) Q:IEN85="" D
- ..N FDA,SEQ,MSG,DIERR,DIMSG,R85
- ..S R85=$G(^SDEC(409.85,IEN85,0)) Q:R85=""
- ..Q:$P($G(R85),"^",17)'="O" ;Current status (#23)
- ..Q:DFN85'=$P(R85,"^")
- ..Q:$O(^SDEC(409.85,IEN85,4,0))'>0 ;Patient contact multiple (#44)
- ..;
- ..;Set FDA for top level fields of File #409.86
- ..S FDA(409.86,"+1,",.01)=DFN85 ;Patient
- ..S FDA(409.86,"+1,",1)=$P(R85,"^",9) ;Req specific clinic (#8,P44) -> Clinic
- ..S FDA(409.86,"+1,",2)=$P(R85,"^",16) ;CID/Preferred Date of Appt (#22) -> Preferred date
- ..S FDA(409.86,"+1,",2.1)=$P(R85,"^",5) ;Request type (#4) -> Request type
- ..S FDA(409.86,"+1,",2.2)=1 ;Sequence
- ..S FDA(409.86,"+1,",1.1)=$P(R85,"^",4) ;Req service/specialty (#8.5,P40.7) -> Service
- ..;
- ..;Loop through PATIENT CONTACT multiple (#44) of File #409.85 and set FDA array
- ..;for the DATE/TIME of CONTACT multiple (#3) of File #409.86
- ..S SEQ=1
- ..S CN85="" F S CN85=$O(^SDEC(409.85,IEN85,4,CN85)) Q:CN85'>0 D
- ...S CR85=$G(^SDEC(409.85,IEN85,4,CN85,0)) Q:CR85=""
- ...S CDT85=$P(CR85,"^") Q:CDT85="" ;Date entered (#.01)
- ...S CU85=$P(CR85,"^",2) Q:CU85="" ;Entered by user (#2,P200)
- ...S CA85=$P(CR85,"^",3) Q:CA85="" ;Action (#3)
- ...S CLM85="" I CA85="M" S CA85="C",CLM85=1
- ...;
- ...S SEQ=SEQ+1
- ...S IENS="+"_SEQ_",+1,"
- ...S FDA(409.863,IENS,.01)=$P(CR85,"^")
- ...S FDA(409.863,IENS,1)=CA85 ;Contact type
- ...S:SEQ=2 FDA(409.863,IENS,2)=$P(R85,"^",18) ;Comments from top level #409.85,25 -> Comments
- ...S FDA(409.863,IENS,3)=CLM85 ;Left message
- ...S FDA(409.863,IENS,4)=SEQ-1 ;Sequence
- ...S FDA(409.863,IENS,5)=CU85 ;User entered contact
- ...S FDA(409.863,IENS,6)=CDT85 ;Date/time entered
- ..;
- ..S ^XTMP("SDEC671")=DFN85_"^"_IEN85
- ..D UPDATE^DIE("","FDA","","MSG")
- Q
- ;
- POST2 ;
- N PAT84,ST84,APP84,IEN84,CL84P,CL84,DFN84,PAT0,STA
- S J=0
- ;
- S ADT84="" F S ADT84=$O(^SDEC(409.84,"B",ADT84)) Q:ADT84'>0 D
- .S IEN84="" F S IEN84=$O(^SDEC(409.84,"B",ADT84,IEN84)) Q:IEN84="" D
- ..S PAT84="" S PAT84=^SDEC(409.84,IEN84,0) Q:PAT84=""
- ..Q:$P($G(PAT84),"^",5)=""
- ..Q:$P($G(PAT84),"^",3)'="" ;Quit if cancel d/t entered
- ..Q:$P($G(PAT84),"^",4)'=""
- ..Q:$P($G(PAT84),"^",12)'=""
- ..Q:$P($G(PAT84),"^",14)'="" ;Quit if checkout d/t entered
- ..S ST84="" S ST84=$P($G(PAT84),"^",17)
- ..S DFN84="" S DFN84=$P($G(PAT84),"^",5) Q:DFN84=""
- ..S CL84P="" S CL84P=$P($G(PAT84),"^",7) Q:CL84P=""
- ..S CL84="" S CL84=$$GET1^DIQ(409.831,CL84P,.04,"I") Q:CL84=""
- ..S PAT0="" S PAT0=$G(^DPT(DFN84,0)) Q:PAT0=""
- ..S STA="" S STA=$$STATUS^SDAM1(DFN84,ADT84,CL84,PAT0)
- ..I ($P(STA,";",1)=11)!($P(STA,";",1)=3) D DEL
- ..Q
- Q
- ;
- DEL ;
- N REC2
- S REC2=$G(^DPT(DFN84,"S",ADT84,0))
- Q:$P(REC2,"^",1)=CL84
- W !,IEN84_" "_ADT84_" "_$P(^DPT(DFN84,0),"^",1)
- S J=J+1 S ^XTMP("673SDEC",J)=IEN84_" "_ADT84_" "_$P(^DPT(DFN84,0),"^",1)
- S DIK="^SDEC(409.84,",DA=IEN84 D ^DIK
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDEC671 6487 printed Jan 18, 2025@03:52:12 Page 2
- 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
- +2 QUIT
- +3 ;
- POST ;Entry point for Post InstalL
- +1 DO ADDPROT
- +2 DO TRANSFER
- +3 DO POST2
- +4 QUIT
- +5 ;
- ADDPROT ;Link OR and SD protocols
- +1 NEW RET
- +2 DO BMES^XPDUTL("Adding Protocol 'OR RECEIVE' to the protocol 'SD EVSEND OR'.")
- +3 SET RET=$$ADD^XPDPROT("SD EVSEND OR","OR RECEIVE","",1)
- +4 if 'RET
- DO MES^XPDUTL("ERROR: "_$PIECE(RET,"^",2)_" **")
- +5 ;
- +6 DO BMES^XPDUTL("Adding Protocol 'OCX ORDER CHECK HL7 RECIEVE' to the protocol 'SD EVSEND OR'.")
- +7 SET RET=$$ADD^XPDPROT("SD EVSEND OR","OCX ORDER CHECK HL7 RECIEVE","",1)
- +8 if 'RET
- DO MES^XPDUTL("ERROR: "_$PIECE(RET,"^",2)_" **")
- +9 ;
- +10 IF $$PATCH^XPDUTL("OR*3.0*434")
- Begin DoDot:1
- +11 DO BMES^XPDUTL("Adding Protocol 'SD RECEIVE OR' to the protocol 'OR EVSEND SD'.")
- +12 SET RET=$$ADD^XPDPROT("OR EVSEND SD","SD RECEIVE OR","",1)
- +13 if 'RET
- DO MES^XPDUTL("ERROR: "_$PIECE(RET,"^",2)_" **")
- End DoDot:1
- +14 QUIT
- +15 ;
- TRANSFER ;Copy data from File #409.85 to #409.86
- +1 NEW PATCH,STUS
- +2 SET PATCH=$ORDER(^XPD(9.7,"B","SD*5.3*671",""),-1)
- IF PATCH>0
- Begin DoDot:1
- +3 SET STUS=$$GET1^DIQ(9,7,PATCH,.02,"I")
- +4 IF STUS=3
- DO BMES^XPDUTL("POST-INIT routine has already run!")
- End DoDot:1
- +5 if $GET(STUS)=3
- QUIT
- +6 IF $GET(^XTMP("SDEC671"))
- Begin DoDot:1
- +7 DO BMES^XPDUTL("POST-INIT routine already started, PLEASE refer to patch instructions to restart!")
- End DoDot:1
- +8 if $GET(^XTMP("SDEC671"))
- QUIT
- +9 NEW CA85,CDT85,CLM85,CN85,CR85,CU85,DFN85
- +10 SET ^XTMP("SDEC671")=""
- +11 ;
- +12 ;Loop through entries in file #409.85
- +13 SET DFN85=0
- FOR
- SET DFN85=$ORDER(^SDEC(409.85,"B",DFN85))
- if DFN85'>0
- QUIT
- Begin DoDot:1
- +14 SET IEN85=""
- FOR
- SET IEN85=$ORDER(^SDEC(409.85,"B",DFN85,IEN85))
- if IEN85=""
- QUIT
- Begin DoDot:2
- +15 NEW FDA,SEQ,MSG,DIERR,DIMSG,R85
- +16 SET R85=$GET(^SDEC(409.85,IEN85,0))
- if R85=""
- QUIT
- +17 ;Current status (#23)
- if $PIECE($GET(R85),"^",17)'="O"
- QUIT
- +18 if DFN85'=$PIECE(R85,"^")
- QUIT
- +19 ;Patient contact multiple (#44)
- if $ORDER(^SDEC(409.85,IEN85,4,0))'>0
- QUIT
- +20 ;
- +21 ;Set FDA for top level fields of File #409.86
- +22 ;Patient
- SET FDA(409.86,"+1,",.01)=DFN85
- +23 ;Req specific clinic (#8,P44) -> Clinic
- SET FDA(409.86,"+1,",1)=$PIECE(R85,"^",9)
- +24 ;CID/Preferred Date of Appt (#22) -> Preferred date
- SET FDA(409.86,"+1,",2)=$PIECE(R85,"^",16)
- +25 ;Request type (#4) -> Request type
- SET FDA(409.86,"+1,",2.1)=$PIECE(R85,"^",5)
- +26 ;Sequence
- SET FDA(409.86,"+1,",2.2)=1
- +27 ;Req service/specialty (#8.5,P40.7) -> Service
- SET FDA(409.86,"+1,",1.1)=$PIECE(R85,"^",4)
- +28 ;
- +29 ;Loop through PATIENT CONTACT multiple (#44) of File #409.85 and set FDA array
- +30 ;for the DATE/TIME of CONTACT multiple (#3) of File #409.86
- +31 SET SEQ=1
- +32 SET CN85=""
- FOR
- SET CN85=$ORDER(^SDEC(409.85,IEN85,4,CN85))
- if CN85'>0
- QUIT
- Begin DoDot:3
- +33 SET CR85=$GET(^SDEC(409.85,IEN85,4,CN85,0))
- if CR85=""
- QUIT
- +34 ;Date entered (#.01)
- SET CDT85=$PIECE(CR85,"^")
- if CDT85=""
- QUIT
- +35 ;Entered by user (#2,P200)
- SET CU85=$PIECE(CR85,"^",2)
- if CU85=""
- QUIT
- +36 ;Action (#3)
- SET CA85=$PIECE(CR85,"^",3)
- if CA85=""
- QUIT
- +37 SET CLM85=""
- IF CA85="M"
- SET CA85="C"
- SET CLM85=1
- +38 ;
- +39 SET SEQ=SEQ+1
- +40 SET IENS="+"_SEQ_",+1,"
- +41 SET FDA(409.863,IENS,.01)=$PIECE(CR85,"^")
- +42 ;Contact type
- SET FDA(409.863,IENS,1)=CA85
- +43 ;Comments from top level #409.85,25 -> Comments
- if SEQ=2
- SET FDA(409.863,IENS,2)=$PIECE(R85,"^",18)
- +44 ;Left message
- SET FDA(409.863,IENS,3)=CLM85
- +45 ;Sequence
- SET FDA(409.863,IENS,4)=SEQ-1
- +46 ;User entered contact
- SET FDA(409.863,IENS,5)=CU85
- +47 ;Date/time entered
- SET FDA(409.863,IENS,6)=CDT85
- End DoDot:3
- +48 ;
- +49 SET ^XTMP("SDEC671")=DFN85_"^"_IEN85
- +50 DO UPDATE^DIE("","FDA","","MSG")
- End DoDot:2
- End DoDot:1
- +51 QUIT
- +52 ;
- RESTART ;Copy data from File #409.85 to #409.86
- +1 NEW CA85,CDT85,CLM85,CN85,CR85,CU85,DFN85
- +2 ;
- +3 ;Loop through entries in file #409.85
- +4 IF '$GET(^XTMP("SDEC671"))
- SET $PIECE(^XTMP("SDEC671"),"^",1)=0
- +5 SET DFN85=$PIECE(^XTMP("SDEC671"),"^",1)
- FOR
- SET DFN85=$ORDER(^SDEC(409.85,"B",DFN85))
- if DFN85'>0
- QUIT
- Begin DoDot:1
- +6 SET IEN85=""
- FOR
- SET IEN85=$ORDER(^SDEC(409.85,"B",DFN85,IEN85))
- if IEN85=""
- QUIT
- Begin DoDot:2
- +7 NEW FDA,SEQ,MSG,DIERR,DIMSG,R85
- +8 SET R85=$GET(^SDEC(409.85,IEN85,0))
- if R85=""
- QUIT
- +9 ;Current status (#23)
- if $PIECE($GET(R85),"^",17)'="O"
- QUIT
- +10 if DFN85'=$PIECE(R85,"^")
- QUIT
- +11 ;Patient contact multiple (#44)
- if $ORDER(^SDEC(409.85,IEN85,4,0))'>0
- QUIT
- +12 ;
- +13 ;Set FDA for top level fields of File #409.86
- +14 ;Patient
- SET FDA(409.86,"+1,",.01)=DFN85
- +15 ;Req specific clinic (#8,P44) -> Clinic
- SET FDA(409.86,"+1,",1)=$PIECE(R85,"^",9)
- +16 ;CID/Preferred Date of Appt (#22) -> Preferred date
- SET FDA(409.86,"+1,",2)=$PIECE(R85,"^",16)
- +17 ;Request type (#4) -> Request type
- SET FDA(409.86,"+1,",2.1)=$PIECE(R85,"^",5)
- +18 ;Sequence
- SET FDA(409.86,"+1,",2.2)=1
- +19 ;Req service/specialty (#8.5,P40.7) -> Service
- SET FDA(409.86,"+1,",1.1)=$PIECE(R85,"^",4)
- +20 ;
- +21 ;Loop through PATIENT CONTACT multiple (#44) of File #409.85 and set FDA array
- +22 ;for the DATE/TIME of CONTACT multiple (#3) of File #409.86
- +23 SET SEQ=1
- +24 SET CN85=""
- FOR
- SET CN85=$ORDER(^SDEC(409.85,IEN85,4,CN85))
- if CN85'>0
- QUIT
- Begin DoDot:3
- +25 SET CR85=$GET(^SDEC(409.85,IEN85,4,CN85,0))
- if CR85=""
- QUIT
- +26 ;Date entered (#.01)
- SET CDT85=$PIECE(CR85,"^")
- if CDT85=""
- QUIT
- +27 ;Entered by user (#2,P200)
- SET CU85=$PIECE(CR85,"^",2)
- if CU85=""
- QUIT
- +28 ;Action (#3)
- SET CA85=$PIECE(CR85,"^",3)
- if CA85=""
- QUIT
- +29 SET CLM85=""
- IF CA85="M"
- SET CA85="C"
- SET CLM85=1
- +30 ;
- +31 SET SEQ=SEQ+1
- +32 SET IENS="+"_SEQ_",+1,"
- +33 SET FDA(409.863,IENS,.01)=$PIECE(CR85,"^")
- +34 ;Contact type
- SET FDA(409.863,IENS,1)=CA85
- +35 ;Comments from top level #409.85,25 -> Comments
- if SEQ=2
- SET FDA(409.863,IENS,2)=$PIECE(R85,"^",18)
- +36 ;Left message
- SET FDA(409.863,IENS,3)=CLM85
- +37 ;Sequence
- SET FDA(409.863,IENS,4)=SEQ-1
- +38 ;User entered contact
- SET FDA(409.863,IENS,5)=CU85
- +39 ;Date/time entered
- SET FDA(409.863,IENS,6)=CDT85
- End DoDot:3
- +40 ;
- +41 SET ^XTMP("SDEC671")=DFN85_"^"_IEN85
- +42 DO UPDATE^DIE("","FDA","","MSG")
- End DoDot:2
- End DoDot:1
- +43 QUIT
- +44 ;
- POST2 ;
- +1 NEW PAT84,ST84,APP84,IEN84,CL84P,CL84,DFN84,PAT0,STA
- +2 SET J=0
- +3 ;
- +4 SET ADT84=""
- FOR
- SET ADT84=$ORDER(^SDEC(409.84,"B",ADT84))
- if ADT84'>0
- QUIT
- Begin DoDot:1
- +5 SET IEN84=""
- FOR
- SET IEN84=$ORDER(^SDEC(409.84,"B",ADT84,IEN84))
- if IEN84=""
- QUIT
- Begin DoDot:2
- +6 SET PAT84=""
- SET PAT84=^SDEC(409.84,IEN84,0)
- if PAT84=""
- QUIT
- +7 if $PIECE($GET(PAT84),"^",5)=""
- QUIT
- +8 ;Quit if cancel d/t entered
- if $PIECE($GET(PAT84),"^",3)'=""
- QUIT
- +9 if $PIECE($GET(PAT84),"^",4)'=""
- QUIT
- +10 if $PIECE($GET(PAT84),"^",12)'=""
- QUIT
- +11 ;Quit if checkout d/t entered
- if $PIECE($GET(PAT84),"^",14)'=""
- QUIT
- +12 SET ST84=""
- SET ST84=$PIECE($GET(PAT84),"^",17)
- +13 SET DFN84=""
- SET DFN84=$PIECE($GET(PAT84),"^",5)
- if DFN84=""
- QUIT
- +14 SET CL84P=""
- SET CL84P=$PIECE($GET(PAT84),"^",7)
- if CL84P=""
- QUIT
- +15 SET CL84=""
- SET CL84=$$GET1^DIQ(409.831,CL84P,.04,"I")
- if CL84=""
- QUIT
- +16 SET PAT0=""
- SET PAT0=$GET(^DPT(DFN84,0))
- if PAT0=""
- QUIT
- +17 SET STA=""
- SET STA=$$STATUS^SDAM1(DFN84,ADT84,CL84,PAT0)
- +18 IF ($PIECE(STA,";",1)=11)!($PIECE(STA,";",1)=3)
- DO DEL
- +19 QUIT
- End DoDot:2
- End DoDot:1
- +20 QUIT
- +21 ;
- DEL ;
- +1 NEW REC2
- +2 SET REC2=$GET(^DPT(DFN84,"S",ADT84,0))
- +3 if $PIECE(REC2,"^",1)=CL84
- QUIT
- +4 WRITE !,IEN84_" "_ADT84_" "_$PIECE(^DPT(DFN84,0),"^",1)
- +5 SET J=J+1
- SET ^XTMP("673SDEC",J)=IEN84_" "_ADT84_" "_$PIECE(^DPT(DFN84,0),"^",1)
- +6 SET DIK="^SDEC(409.84,"
- SET DA=IEN84
- DO ^DIK
- +7 QUIT