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

XUPSB01.m

Go to the documentation of this file.
  1. XUPSB01 ;ALB/CMC - B01/B02 BUILDER ;2 Sep 2010 5:25 PM
  1. ;;8.0;KERNEL;**551**;Jul 10, 1995;Build 2
  1. ;
  1. BLD(CONTEXT,NPIEN,PIEN) ;BUILD AND SEND B01 OR B02 MSG
  1. ;CONTEXT - is ADD or UPDATE depending on the event
  1. ;NPIEN - is the internal entry number of the record in file 200
  1. ;PIEN - is the internal entry number of the record in file 450
  1. ;
  1. TASK ;
  1. I CONTEXT="UPDATE",$G(NPIEN)'="" D INIT^HLFNC2("XUPS B02 SERVER",.HL) S XUPS="XUPS B02 SERVER HLO MPI",XUPSIEN=NPIEN
  1. I CONTEXT="ADD",$G(NPIEN)'="" D INIT^HLFNC2("XUPS B01 SERVER",.HL) S XUPS="XUPS B01 SERVER HLO MPI",XUPSIEN=NPIEN
  1. I CONTEXT="ADD",$G(PIEN)'="" D INIT^HLFNC2("PRS B01 SERVER",.HL) S XUPS="PRS B01 SERVER HLO MPI",XUPSIEN=PIEN
  1. I CONTEXT="UPDATE",$G(PIEN)'="" D INIT^HLFNC2("PRS B02 SERVER",.HL) S XUPS="PRS B02 SERVER HLO MPI",XUPSIEN=PIEN
  1. I $O(HL(""))="" Q "-1^"_$P(HL,"^",2)
  1. N HLECH,HLFS,COMP,REP,SUBCOMP,ERR,STF,XUORG,PRA,HLA,TIEN
  1. S HLECH=HL("ECH"),HLFS=HL("FS"),COMP=$E(HL("ECH"),1),REP=$E(HL("ECH"),2),SUBCOMP=$E(HL("ECH"),4)
  1. S ERR=""
  1. ;
  1. I $G(NPIEN)'="" D
  1. .;BUILD FOR NEW PERSON
  1. .S EVN="EVN"_HL("FS")_HL("FS")_$$HLDATE^HLFNC(DT)_HL("FS")_HL("FS")
  1. .D EN^XUPSSTF(NPIEN,"2,3,4,5,6,10,11",.HL,.STF,.STFC) Q:+STF=-1
  1. .D EN^XUPSORG(NPIEN,.HL,.XUORG) Q:+$G(XUORG)=-1
  1. .S PRA=$$EN^XUPSPRA(NPIEN,"6",.HL) Q:+PRA=-1
  1. .S HLA("HLS",1)=EVN
  1. .S HLA("HLS",2)=STF
  1. .I $D(STFC) D
  1. ..;STFC HAS THE REST OF THE STF SEGMENT
  1. ..S STFCNT=1,STFIEN=0
  1. ..F S STFIEN=$O(STFC(STFIEN)) Q:'STFIEN D
  1. ...S HLA("HLS",2,STFCNT)=STFC(STFIEN)
  1. .S HLA("HLS",3)=PRA,CNT=4
  1. .N TMP S TMP=0 F S TMP=$O(XUORG(TMP)) Q:TMP="" S HLA("HLS",CNT)=XUORG(TMP),CNT=CNT+1
  1. ;
  1. I $G(PIEN)'="" D
  1. .;BUILD FOR PAID EMPLOYEE
  1. .S EVN="EVN"_HL("FS")_HL("FS")_$$HLDATE^HLFNC(DT)_HL("FS")_HL("FS")
  1. .S STF=$$STF^PRSMPI(PIEN,.HL,"2,3,5,6,10,11") Q:+STF=-1
  1. .S HLA("HLS",1)=EVN
  1. .S HLA("HLS",2)=STF
  1. ;
  1. I $D(HLA("HLS")) D
  1. .;SEND VIA HLO
  1. .;LINK IS HARD SET IN PROTOCOL AT THIS POINT
  1. .S TIEN=XUPSIEN
  1. .I $L(TIEN)<3 S TIEN=0_TIEN I $L(TIEN)<3 S TIEN=0_TIEN
  1. .S HLP("SEQUENCE QUEUE")="XUPS B01 B02 "_$E(TIEN,$L(TIEN)-3,$L(TIEN))
  1. .S HLP("QUEUE")="XUPS B01 B02 "_$E(TIEN,$L(TIEN)-3,$L(TIEN))
  1. .I '$$PATCH^XPDUTL("HL*1.6*134") S HLRESLT=$$EN^HLOCNRT(XUPS,"LM",.HLP)
  1. .I $$PATCH^XPDUTL("HL*1.6*134") S HLRESLT=$$EN^HLOCNRT(XUPS,"LM",.HLP,"",.MHLOMSG)
  1. .D KILL^HLTRANS
  1. Q
  1. ;
  1. B01AP ;APP ACK PROCEES FOR B01 for NEW PERSON
  1. ;PARSE BACK TO ORIGINAL MESSAGE TO GET 'WHO' we are triggering B02 for
  1. I '$$STARTMSG^HLOPRS(.HLMSTATE,HLMSGIEN,.HDR) D Q ;COULDN'T GET MESSAGE, DO WHAT?
  1. .;NOT SURE WHAT WE ARE DOING HERE
  1. ; can successfully get message
  1. S HL("ETN")=HDR("EVENT"),HL("Q")="""""",HL("FS")=HDR("FIELD SEPARATOR")
  1. S HL("SFN")=HDR("SENDING FACILITY",1)_HDR("COMPONENT SEPARATOR")_HDR("SENDING FACILITY",2)_HDR("COMPONENT SEPARATOR")_HDR("SENDING FACILITY",3)
  1. S HL("ECH")=HDR("COMPONENT SEPARATOR")_HDR("REPETITION SEPARATOR")_HDR("ESCAPE CHARACTER")_HDR("SUBCOMPONENT SEPARATOR")
  1. F Q:'$$HLNEXT^HLOMSG(.HLMSTATE,.SEG) D
  1. .S SG=$E(SEG(1),1,3)
  1. .I SG="MSA" S MSG=SEG(1) D MSA(.MSG,.ARRAY,.HL,.HDR)
  1. ;set the new enumeration competed date/time field
  1. ;
  1. Q
  1. MSA(MSG,ARRAY,HL,HDR) ;
  1. N EXIT,ACKID,TMP,SEG,SG,HDR2,HLMST2,ERR,RSLT,ARRAY2,MSG2,ERROR,TMP,ARR,RES,FIND,WHO,TXT
  1. S EXIT=0,ACKID=$G(HLMSGIEN) K HLMST2
  1. S TMP=$$STARTMSG^HLOPRS(.HLMST2,HLMSTATE("ACK TO IEN"),.HDR2)
  1. S HL("ETN")=HDR2("EVENT"),HL("Q")="""""",HL("FS")=HDR2("FIELD SEPARATOR")
  1. S HL("SFN")=HDR2("RECEIVING FACILITY",1)_HDR2("COMPONENT SEPARATOR")_HDR2("RECEIVING FACILITY",2)_HDR2("COMPONENT SEPARATOR")_HDR2("RECEIVING FACILITY",3) ;WHO THE MESSAGE WENT TO ORIGINALLY
  1. S HL("ECH")=HDR2("COMPONENT SEPARATOR")_HDR2("REPETITION SEPARATOR")_HDR2("ESCAPE CHARACTER")_HDR2("SUBCOMPONENT SEPARATOR")
  1. N SEQ2,LASTID,IDCNT,IDS,CNT,ACNT,ID,NPIEN,PIEN
  1. S NPIEN="",PIEN=""
  1. I TMP D
  1. .F Q:'$$HLNEXT^HLOMSG(.HLMST2,.SEG) D
  1. ..S SG=$E(SEG(1),1,3)
  1. ..I SG="STF" D
  1. ...;NEED SEQ 2 fields
  1. ...S SEQ2=$P(SG,HDR("FIELD SEPARATOR"),3)
  1. ...S IDCNT=1,IDS="" F S IDS=$P(SEQ2,HDR("REPETITION SEPARATOR"),IDCNT) Q:IDS="" D
  1. ....S IEN=$P(IDS,HDR("COMPONENT SEPARATOR"),1)
  1. ....S AA=$P($P(IDS,HDR("COMPONENT SEPARATOR"),4),HDR("SUBCOMPONENT SEPARATOR"),1)
  1. ....S TYPE=$P(IDS,HDR("COMPONENT SEPARATOR"),5)
  1. ....S FAC=$P($P(IDS,HDR("COMPONENT SEPARATOR"),6),HDR("SUBCOMPONENT SEPARATOR"),2)
  1. ....I AA="USVHA",TYPE="PN" S NPIEN=IEN
  1. ....I AA="USVHA",TYPE="EI" S PIEN=IEN
  1. ....S IDCNT=IDCNT+1
  1. .;
  1. .I $P(MSG,HDR("FIELD SEPARATOR"),2)'="AA" D
  1. ..;NOT A SUCCESSFULLY PROCESSED MSG -- NOT AA -- LOG EXCEPTION?
  1. .I $P(MSG,HDR("FIELD SEPARATOR"),2)="AA" D
  1. ..;SET enumeration complete date/time field
  1. ..;which file? 200 or 450
  1. ..I $G(NPIEN)'="",HDR("SENDING APPLICATION")["XUPS" D
  1. ...;FILE 200
  1. ...D NOW^%DTC
  1. ...S FDA(200,NPIEN_",",901)=%
  1. ...D FILE^DIE("E","FDA","PRSERR")
  1. ..I $G(PIEN)'="",HDR("SENDING APPLICATION")["PRS" D
  1. ...;FILE 450
  1. ...D NOW^%DTC
  1. ...S FDA(450,PIEN_",",901)=%
  1. ...D FILE^DIE("E","FDA","PRSERR")
  1. ..;trigger PMU-B02 update message (task)
  1. ..S ZTSAVE("CONTEXT")="UPDATE"
  1. ..I HDR("SENDING APPLICATION")["XUPS" S ZTSAVE("NPIEN")=NPIEN
  1. ..I HDR("SENDING APPLICATION")["PRSMPI" S ZTSAVE("PIEN")=PIEN
  1. ..S ZTRTN="TASK^XUPSB01",ZTDESC="B02 HLO to MPI for NPIEN= "_$G(ZTSAVE("NPIEN"))_" PIEN= "_$G(ZTSAVE("PIEN"))
  1. ..S ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
  1. ..D ^%ZTLOAD
  1. ..K ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTREQ
  1. ;
  1. Q
  1. ;
  1. B02AP ;APP ACK PROCESS FOR B02 for NEW PERSON
  1. ;nothing needed at this point
  1. Q
  1. ;
  1. STF(SG,HDR) ;STF TESTER
  1. ;NEED SEQ 2 fields
  1. S SEQ2=$P(SG,HDR("FIELD SEPARATOR"),3)
  1. S IDCNT=1,IDS="" F S IDS=$P(SEQ2,HDR("REPETITION SEPARATOR"),IDCNT) Q:IDS="" D
  1. .S IEN=$P(IDS,HDR("COMPONENT SEPARATOR"),1)
  1. .S AA=$P($P(IDS,HDR("COMPONENT SEPARATOR"),4),HDR("SUBCOMPONENT SEPARATOR"),1)
  1. .S TYPE=$P(IDS,HDR("COMPONENT SEPARATOR"),5)
  1. .S FAC=$P($P(IDS,HDR("COMPONENT SEPARATOR"),6),HDR("SUBCOMPONENT SEPARATOR"),2)
  1. .I AA="USVHA",TYPE="PN" S NPIEN=IEN
  1. .I AA="USVHA",TYPE="EI" S PIEN=IEN
  1. .S IDCNT=IDCNT+1
  1. ;
  1. ;SET enumeration complete date/time field
  1. ;which file? 200 or 450
  1. UP I $G(NPIEN)'="",HDR("SENDING APPLICATION")="XUPS APP" D
  1. .;FILE 200
  1. .D NOW^%DTC
  1. .S FDA(200,NPIEN_",",901)=%
  1. .D FILE^DIE("E","FDA","PRSERR")
  1. I $G(PIEN)'="",HDR("SENDING APPLICATION")="PRSMPI APP" D
  1. .;FILE 450
  1. .D NOW^%DTC
  1. .S FDA(450,PIEN_",",901)=%
  1. .D FILE^DIE("E","FDA","PRSERR")
  1. ;trigger PMU-B02 update message (task)
  1. S ZTSAVE("CONTEXT")="UPDATE"
  1. I HDR("SENDING APPLICATION")="XUPS APP" S ZTSAVE("NPIEN")=NPIEN
  1. I HDR("SENDING APPLICATION")="PRSMPI APP" S ZTSAVE("PIEN")=PIEN
  1. S ZTRTN="TASK^XUPSB01",ZTDESC="B02 HLO to MPI for NPIEN= "_$G(ZTSAVE("NPIEN"))_" PIEN= "_$G(ZTSAVE("PIEN"))
  1. S ZTIO="",ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
  1. D ^%ZTLOAD
  1. ;K ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTREQ
  1. Q