- XUPSB01 ;ALB/CMC - B01/B02 BUILDER ;2 Sep 2010 5:25 PM
- ;;8.0;KERNEL;**551**;Jul 10, 1995;Build 2
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUPSB01 6839 printed Jan 18, 2025@03:12:50 Page 2
- XUPSB01 ;ALB/CMC - B01/B02 BUILDER ;2 Sep 2010 5:25 PM
- +1 ;;8.0;KERNEL;**551**;Jul 10, 1995;Build 2
- +2 ;
- BLD(CONTEXT,NPIEN,PIEN) ;BUILD AND SEND B01 OR B02 MSG
- +1 ;CONTEXT - is ADD or UPDATE depending on the event
- +2 ;NPIEN - is the internal entry number of the record in file 200
- +3 ;PIEN - is the internal entry number of the record in file 450
- +4 ;
- TASK ;
- +1 IF CONTEXT="UPDATE"
- IF $GET(NPIEN)'=""
- DO INIT^HLFNC2("XUPS B02 SERVER",.HL)
- SET XUPS="XUPS B02 SERVER HLO MPI"
- SET XUPSIEN=NPIEN
- +2 IF CONTEXT="ADD"
- IF $GET(NPIEN)'=""
- DO INIT^HLFNC2("XUPS B01 SERVER",.HL)
- SET XUPS="XUPS B01 SERVER HLO MPI"
- SET XUPSIEN=NPIEN
- +3 IF CONTEXT="ADD"
- IF $GET(PIEN)'=""
- DO INIT^HLFNC2("PRS B01 SERVER",.HL)
- SET XUPS="PRS B01 SERVER HLO MPI"
- SET XUPSIEN=PIEN
- +4 IF CONTEXT="UPDATE"
- IF $GET(PIEN)'=""
- DO INIT^HLFNC2("PRS B02 SERVER",.HL)
- SET XUPS="PRS B02 SERVER HLO MPI"
- SET XUPSIEN=PIEN
- +5 IF $ORDER(HL(""))=""
- QUIT "-1^"_$PIECE(HL,"^",2)
- +6 NEW HLECH,HLFS,COMP,REP,SUBCOMP,ERR,STF,XUORG,PRA,HLA,TIEN
- +7 SET HLECH=HL("ECH")
- SET HLFS=HL("FS")
- SET COMP=$EXTRACT(HL("ECH"),1)
- SET REP=$EXTRACT(HL("ECH"),2)
- SET SUBCOMP=$EXTRACT(HL("ECH"),4)
- +8 SET ERR=""
- +9 ;
- +10 IF $GET(NPIEN)'=""
- Begin DoDot:1
- +11 ;BUILD FOR NEW PERSON
- +12 SET EVN="EVN"_HL("FS")_HL("FS")_$$HLDATE^HLFNC(DT)_HL("FS")_HL("FS")
- +13 DO EN^XUPSSTF(NPIEN,"2,3,4,5,6,10,11",.HL,.STF,.STFC)
- if +STF=-1
- QUIT
- +14 DO EN^XUPSORG(NPIEN,.HL,.XUORG)
- if +$GET(XUORG)=-1
- QUIT
- +15 SET PRA=$$EN^XUPSPRA(NPIEN,"6",.HL)
- if +PRA=-1
- QUIT
- +16 SET HLA("HLS",1)=EVN
- +17 SET HLA("HLS",2)=STF
- +18 IF $DATA(STFC)
- Begin DoDot:2
- +19 ;STFC HAS THE REST OF THE STF SEGMENT
- +20 SET STFCNT=1
- SET STFIEN=0
- +21 FOR
- SET STFIEN=$ORDER(STFC(STFIEN))
- if 'STFIEN
- QUIT
- Begin DoDot:3
- +22 SET HLA("HLS",2,STFCNT)=STFC(STFIEN)
- End DoDot:3
- End DoDot:2
- +23 SET HLA("HLS",3)=PRA
- SET CNT=4
- +24 NEW TMP
- SET TMP=0
- FOR
- SET TMP=$ORDER(XUORG(TMP))
- if TMP=""
- QUIT
- SET HLA("HLS",CNT)=XUORG(TMP)
- SET CNT=CNT+1
- End DoDot:1
- +25 ;
- +26 IF $GET(PIEN)'=""
- Begin DoDot:1
- +27 ;BUILD FOR PAID EMPLOYEE
- +28 SET EVN="EVN"_HL("FS")_HL("FS")_$$HLDATE^HLFNC(DT)_HL("FS")_HL("FS")
- +29 SET STF=$$STF^PRSMPI(PIEN,.HL,"2,3,5,6,10,11")
- if +STF=-1
- QUIT
- +30 SET HLA("HLS",1)=EVN
- +31 SET HLA("HLS",2)=STF
- End DoDot:1
- +32 ;
- +33 IF $DATA(HLA("HLS"))
- Begin DoDot:1
- +34 ;SEND VIA HLO
- +35 ;LINK IS HARD SET IN PROTOCOL AT THIS POINT
- +36 SET TIEN=XUPSIEN
- +37 IF $LENGTH(TIEN)<3
- SET TIEN=0_TIEN
- IF $LENGTH(TIEN)<3
- SET TIEN=0_TIEN
- +38 SET HLP("SEQUENCE QUEUE")="XUPS B01 B02 "_$EXTRACT(TIEN,$LENGTH(TIEN)-3,$LENGTH(TIEN))
- +39 SET HLP("QUEUE")="XUPS B01 B02 "_$EXTRACT(TIEN,$LENGTH(TIEN)-3,$LENGTH(TIEN))
- +40 IF '$$PATCH^XPDUTL("HL*1.6*134")
- SET HLRESLT=$$EN^HLOCNRT(XUPS,"LM",.HLP)
- +41 IF $$PATCH^XPDUTL("HL*1.6*134")
- SET HLRESLT=$$EN^HLOCNRT(XUPS,"LM",.HLP,"",.MHLOMSG)
- +42 DO KILL^HLTRANS
- End DoDot:1
- +43 QUIT
- +44 ;
- B01AP ;APP ACK PROCEES FOR B01 for NEW PERSON
- +1 ;PARSE BACK TO ORIGINAL MESSAGE TO GET 'WHO' we are triggering B02 for
- +2 ;COULDN'T GET MESSAGE, DO WHAT?
- IF '$$STARTMSG^HLOPRS(.HLMSTATE,HLMSGIEN,.HDR)
- Begin DoDot:1
- +3 ;NOT SURE WHAT WE ARE DOING HERE
- End DoDot:1
- QUIT
- +4 ; can successfully get message
- +5 SET HL("ETN")=HDR("EVENT")
- SET HL("Q")=""""""
- SET HL("FS")=HDR("FIELD SEPARATOR")
- +6 SET HL("SFN")=HDR("SENDING FACILITY",1)_HDR("COMPONENT SEPARATOR")_HDR("SENDING FACILITY",2)_HDR("COMPONENT SEPARATOR")_HDR("SENDING FACILITY",3)
- +7 SET HL("ECH")=HDR("COMPONENT SEPARATOR")_HDR("REPETITION SEPARATOR")_HDR("ESCAPE CHARACTER")_HDR("SUBCOMPONENT SEPARATOR")
- +8 FOR
- if '$$HLNEXT^HLOMSG(.HLMSTATE,.SEG)
- QUIT
- Begin DoDot:1
- +9 SET SG=$EXTRACT(SEG(1),1,3)
- +10 IF SG="MSA"
- SET MSG=SEG(1)
- DO MSA(.MSG,.ARRAY,.HL,.HDR)
- End DoDot:1
- +11 ;set the new enumeration competed date/time field
- +12 ;
- +13 QUIT
- MSA(MSG,ARRAY,HL,HDR) ;
- +1 NEW EXIT,ACKID,TMP,SEG,SG,HDR2,HLMST2,ERR,RSLT,ARRAY2,MSG2,ERROR,TMP,ARR,RES,FIND,WHO,TXT
- +2 SET EXIT=0
- SET ACKID=$GET(HLMSGIEN)
- KILL HLMST2
- +3 SET TMP=$$STARTMSG^HLOPRS(.HLMST2,HLMSTATE("ACK TO IEN"),.HDR2)
- +4 SET HL("ETN")=HDR2("EVENT")
- SET HL("Q")=""""""
- SET HL("FS")=HDR2("FIELD SEPARATOR")
- +5 ;WHO THE MESSAGE WENT TO ORIGINALLY
- SET HL("SFN")=HDR2("RECEIVING FACILITY",1)_HDR2("COMPONENT SEPARATOR")_HDR2("RECEIVING FACILITY",2)_HDR2("COMPONENT SEPARATOR")_HDR2("RECEIVING FACILITY",3)
- +6 SET HL("ECH")=HDR2("COMPONENT SEPARATOR")_HDR2("REPETITION SEPARATOR")_HDR2("ESCAPE CHARACTER")_HDR2("SUBCOMPONENT SEPARATOR")
- +7 NEW SEQ2,LASTID,IDCNT,IDS,CNT,ACNT,ID,NPIEN,PIEN
- +8 SET NPIEN=""
- SET PIEN=""
- +9 IF TMP
- Begin DoDot:1
- +10 FOR
- if '$$HLNEXT^HLOMSG(.HLMST2,.SEG)
- QUIT
- Begin DoDot:2
- +11 SET SG=$EXTRACT(SEG(1),1,3)
- +12 IF SG="STF"
- Begin DoDot:3
- +13 ;NEED SEQ 2 fields
- +14 SET SEQ2=$PIECE(SG,HDR("FIELD SEPARATOR"),3)
- +15 SET IDCNT=1
- SET IDS=""
- FOR
- SET IDS=$PIECE(SEQ2,HDR("REPETITION SEPARATOR"),IDCNT)
- if IDS=""
- QUIT
- Begin DoDot:4
- +16 SET IEN=$PIECE(IDS,HDR("COMPONENT SEPARATOR"),1)
- +17 SET AA=$PIECE($PIECE(IDS,HDR("COMPONENT SEPARATOR"),4),HDR("SUBCOMPONENT SEPARATOR"),1)
- +18 SET TYPE=$PIECE(IDS,HDR("COMPONENT SEPARATOR"),5)
- +19 SET FAC=$PIECE($PIECE(IDS,HDR("COMPONENT SEPARATOR"),6),HDR("SUBCOMPONENT SEPARATOR"),2)
- +20 IF AA="USVHA"
- IF TYPE="PN"
- SET NPIEN=IEN
- +21 IF AA="USVHA"
- IF TYPE="EI"
- SET PIEN=IEN
- +22 SET IDCNT=IDCNT+1
- End DoDot:4
- End DoDot:3
- End DoDot:2
- +23 ;
- +24 IF $PIECE(MSG,HDR("FIELD SEPARATOR"),2)'="AA"
- Begin DoDot:2
- +25 ;NOT A SUCCESSFULLY PROCESSED MSG -- NOT AA -- LOG EXCEPTION?
- End DoDot:2
- +26 IF $PIECE(MSG,HDR("FIELD SEPARATOR"),2)="AA"
- Begin DoDot:2
- +27 ;SET enumeration complete date/time field
- +28 ;which file? 200 or 450
- +29 IF $GET(NPIEN)'=""
- IF HDR("SENDING APPLICATION")["XUPS"
- Begin DoDot:3
- +30 ;FILE 200
- +31 DO NOW^%DTC
- +32 SET FDA(200,NPIEN_",",901)=%
- +33 DO FILE^DIE("E","FDA","PRSERR")
- End DoDot:3
- +34 IF $GET(PIEN)'=""
- IF HDR("SENDING APPLICATION")["PRS"
- Begin DoDot:3
- +35 ;FILE 450
- +36 DO NOW^%DTC
- +37 SET FDA(450,PIEN_",",901)=%
- +38 DO FILE^DIE("E","FDA","PRSERR")
- End DoDot:3
- +39 ;trigger PMU-B02 update message (task)
- +40 SET ZTSAVE("CONTEXT")="UPDATE"
- +41 IF HDR("SENDING APPLICATION")["XUPS"
- SET ZTSAVE("NPIEN")=NPIEN
- +42 IF HDR("SENDING APPLICATION")["PRSMPI"
- SET ZTSAVE("PIEN")=PIEN
- +43 SET ZTRTN="TASK^XUPSB01"
- SET ZTDESC="B02 HLO to MPI for NPIEN= "_$GET(ZTSAVE("NPIEN"))_" PIEN= "_$GET(ZTSAVE("PIEN"))
- +44 SET ZTIO=""
- SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
- +45 DO ^%ZTLOAD
- +46 KILL ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTREQ
- End DoDot:2
- End DoDot:1
- +47 ;
- +48 QUIT
- +49 ;
- B02AP ;APP ACK PROCESS FOR B02 for NEW PERSON
- +1 ;nothing needed at this point
- +2 QUIT
- +3 ;
- STF(SG,HDR) ;STF TESTER
- +1 ;NEED SEQ 2 fields
- +2 SET SEQ2=$PIECE(SG,HDR("FIELD SEPARATOR"),3)
- +3 SET IDCNT=1
- SET IDS=""
- FOR
- SET IDS=$PIECE(SEQ2,HDR("REPETITION SEPARATOR"),IDCNT)
- if IDS=""
- QUIT
- Begin DoDot:1
- +4 SET IEN=$PIECE(IDS,HDR("COMPONENT SEPARATOR"),1)
- +5 SET AA=$PIECE($PIECE(IDS,HDR("COMPONENT SEPARATOR"),4),HDR("SUBCOMPONENT SEPARATOR"),1)
- +6 SET TYPE=$PIECE(IDS,HDR("COMPONENT SEPARATOR"),5)
- +7 SET FAC=$PIECE($PIECE(IDS,HDR("COMPONENT SEPARATOR"),6),HDR("SUBCOMPONENT SEPARATOR"),2)
- +8 IF AA="USVHA"
- IF TYPE="PN"
- SET NPIEN=IEN
- +9 IF AA="USVHA"
- IF TYPE="EI"
- SET PIEN=IEN
- +10 SET IDCNT=IDCNT+1
- End DoDot:1
- +11 ;
- +12 ;SET enumeration complete date/time field
- +13 ;which file? 200 or 450
- UP IF $GET(NPIEN)'=""
- IF HDR("SENDING APPLICATION")="XUPS APP"
- Begin DoDot:1
- +1 ;FILE 200
- +2 DO NOW^%DTC
- +3 SET FDA(200,NPIEN_",",901)=%
- +4 DO FILE^DIE("E","FDA","PRSERR")
- End DoDot:1
- +5 IF $GET(PIEN)'=""
- IF HDR("SENDING APPLICATION")="PRSMPI APP"
- Begin DoDot:1
- +6 ;FILE 450
- +7 DO NOW^%DTC
- +8 SET FDA(450,PIEN_",",901)=%
- +9 DO FILE^DIE("E","FDA","PRSERR")
- End DoDot:1
- +10 ;trigger PMU-B02 update message (task)
- +11 SET ZTSAVE("CONTEXT")="UPDATE"
- +12 IF HDR("SENDING APPLICATION")="XUPS APP"
- SET ZTSAVE("NPIEN")=NPIEN
- +13 IF HDR("SENDING APPLICATION")="PRSMPI APP"
- SET ZTSAVE("PIEN")=PIEN
- +14 SET ZTRTN="TASK^XUPSB01"
- SET ZTDESC="B02 HLO to MPI for NPIEN= "_$GET(ZTSAVE("NPIEN"))_" PIEN= "_$GET(ZTSAVE("PIEN"))
- +15 SET ZTIO=""
- SET ZTDTH=$$FMADD^XLFDT($$NOW^XLFDT,0,0,1,0)
- +16 DO ^%ZTLOAD
- +17 ;K ZTRTN,ZTDESC,ZTIO,ZTSAVE,ZTDTH,ZTREQ
- +18 QUIT