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 Dec 13, 2024@02:51:04 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
