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