source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SDRPA07.m@ 1334

SDRPA07 ;BP-OIFO/ESW - APPOINTMENT BATCH TRANSMISSION BUILDER; ; 9/14/04 9:20am  ; Compiled April 24, 2006 17:00:51
 ;;5.3;Scheduling;**290,333,349,376,446**;AUG 13 1993;Build 77
 ;
 ;
SNDS19(ZTSK,SDBCID,SDMCID) ;Main entry point for the sending of SIU-S19 batch messages to
 ; the National Patient Care Database
 ;
 ;Input  : ZTSK
 ;Output : SDBCID - Batch Control ID
 ;         SDMCID - Message Control ID
 ;
 ;
 ;Declare variables
 N X,X1,X2,%H
 N BATCHC,MSGN,CURLINE
 N LINEN,MSHLINE,XMITERR,HL7XMIT,ERROR,ORIGENT,ORIGMNT
 N HLEID,HL,HLECH,HLFS,HLQ,HLMID,HLMTIEN,HLDT,HLDT1,MSGID,HLRESLT,HLP
 ;Set message count limit for batch message
 ;Initialize global locations
 S XMITERR="^TMP(""SD-PAIT-BLD"","_$J_",""ERRORS"")"
 S HL7XMIT="^TMP(""HLS"","_$J_")"
 K @XMITERR,@HL7XMIT
 ;Initiate
 D INIT^HLFNC2("SD-PAIT-EVENT",.HL)
 ;Unable to initiate HL7 variable - send error bulletin - done
 ;I ($O(HL(""))="") D ERRBUL($P(HL,U,2)) Q  ; create ERRBUL later
 ;Create batch message
 D CREATE^HLTF(.HLMID,.HLMTIEN,.HLDT,.HLDT1)
 ;HLMID - value of batch ID
 ;HLMTIEN - IEN of Message Text file entry
 ;HLDT - current date/time in FM internal format
 ;HLDT1 - current date/time in HL7 format
 N SDA,SDDT S SDA=HLMID,SDDT=HLDT ; to be used to file later
 ;Unable to create batch message - send error bulletin - done
 ;I ('HLMTIEN) D ERRBUL("Unable to create batch HL7 message") Q
 ;Initialize message count
 S BATCHC=0
 ;Initialize message number
 S MSGN=0
 ;Initialize line count
 S LINEN=1
 S CURLINE=LINEN
 ;Loop through list of appointments requiring transmission
 N RUNID S RUNID=$O(^SDWL(409.6,"AD",ZTSK,""))
 N DFN,SD25,SD6,SD8,SD7,SDPATCL S DFN="" F  S DFN=$O(^TMP("SDDPT",$J,DFN)) Q:DFN=""  D
 .N SDP,ICN,SSN,SNM,FNM,MNM,DOB,SDSC,SDSCP,SDENRO,SDAPPT S SDP=^TMP("SDDPT",$J,DFN)
 .S ICN=$P(SDP,U),SSN=$P(SDP,U,2),SNM=$P(SDP,U,3),FNM=$P(SDP,U,4)
 .S MNM=$P(SDP,U,5),DOB=$P(SDP,U,6),SDSC=$P(SDP,U,7),SDSCP=$P(SDP,U,8),SDENRO=$P(SDP,U,9)
 .N SDADT S SDADT="" F  S SDADT=$O(^TMP("SDDPT",$J,DFN,SDADT)) Q:SDADT=""  D
 ..N SDPT,SDCDATE,SDADID,SDSDDT,SDSTAT,SDNAVA,SDCHKOUT,SDCDT,SDARF,SDARDT,SDNEW,SDCL,SDCLNUM,SDSTOP,SDCSTOP,SDFAC,SDDAM,SDCLNM,SDSTOPD,SDCSTOPD
 ..N SDSTOPDD,SD8RD
 ..S SDPT=^TMP("SDDPT",$J,DFN,SDADT),SDADID=$P(SDPT,U),SDDAM=$P(SDPT,U,2),SDSDDT=$P(SDPT,U,3),SDNAVA=$P(SDPT,U,5)
 ..S SDCHKOUT=$P(SDPT,U,6),SDCDT=$P(SDPT,U,7),SDARDT=$P(SDPT,U,9),SDNEW=$P(SDPT,U,10),SDCL=$P(SDPT,U,12),SDCLNM=$P(SDPT,U,13)
 ..S SDSTOP=$P(SDPT,U,14),SDCSTOP=$P(SDPT,U,15),SDFAC=$P(SDPT,U,16),SDPATCL=$P(SDPT,U,4)
 ..S SDAPPT=^TMP("SDDPT",$J,DFN,SDADT,"SCH"),SD25=$P(SDAPPT,"^",2),SD6=$P(SDAPPT,"^",3),SD8=$P(SDAPPT,"^",4),SD8RD=$P(SDAPPT,"^",7)
 ..S SDSTOPDD=^TMP("SDDPT",$J,DFN,SDADT,"STDC"),SDSTOPD=$P(SDSTOPDD,"^"),SDCSTOPD=$P(SDSTOPDD,"^",2)
 ..;calculate consult date if applicable; 446
 ..N SEQ S SEQ=0,SDCDATE="" F  S SEQ=$O(^SC(SDCL,"S",SDADT,1,SEQ)) Q:+SEQ'=SEQ  I $P(^SC(SDCL,"S",SDADT,1,SEQ,0),"^")=DFN D  Q
 ...S SDCSLT=$$GET1^DIQ(44.003,SEQ_","_SDADT_","_SDCL_",",688,"I")  ; consult
 ...Q:SDCSLT=""
 ...I $D(^GMR(123,SDCSLT)) S SDCDATE=$$DTCONV^SDRPA08($$GET1^DIQ(123,SDCSLT_",",3,"I")) ;date converted to HL7
 ..;Calculate message control ID
 ..S MSGN=MSGN+1
 ..S MSGID=HLMID_"-"_MSGN
 ..;Build MSG segment
 ..I (MSGID'="") D
 ...;remember orig message and event type
 ...S ORIGMNT="SIU"
 ...S ORIGENT="S12"
 ...S HL("MNT")="SIU",HL("ETN")=$P(SDAPPT,"^")
 ...;build MSH segment
 ...K RESULT D MSH^HLFNC2(.HL,MSGID,.RESULT)
 ...;reset message & event type to its orig values
 ...S HL("MNT")=ORIGMNT
 ...S HL("ETN")=ORIGENT
 ...;copy MSH segment into HL7 message
 ...S @HL7XMIT@(CURLINE)=RESULT
 ...N SDFACL S SDFACL=$P($$SITE^VASITE(),"^",3)
 ...S $P(@HL7XMIT@(CURLINE),U,4)=SDFACL ;sending facility station #
 ...S $P(@HL7XMIT@(CURLINE),U,5)="SD-AAC-PAIT" ;Receiving Application
 ...S $P(@HL7XMIT@(CURLINE),U,6)=200 ; Receiving Facility
 ...I ($D(RESULT(1))) D
 ....S @HL7XMIT@(CURLINE,1)=RESULT(1)
 ....S CURLINE=CURLINE+1
 ...E  S CURLINE=CURLINE+1
 ..;get list of segments
 ..N SDSCH S SDSCH="SCH"_HLFS_1_"^^^^^"
 ..S SD7=SDNAVA
 ..;S ^TMP("HLS",$J,CURLINE)
 ..S @HL7XMIT@(CURLINE)=SDSCH_SD6_"^"_SD7_"^"_SD8_"^^^"
 ..N SDDAT S SDDAT="~~~"_SDDAM_"~~~"_"Date Appt Created|~~~"_SDSDDT_"~~~"_"Desired Date|~~~"_SDADID_"~~~"_"Appt Date"
 ..S SDDAT=SDDAT_"|~~~"_SDCHKOUT_"~~~"_"Checkout Date"
 ..S SDDAT=SDDAT_"|~~~"_SDCDT_"~~~"_"Cancellation Date"
 ..S SDDAT=SDDAT_"|~~~"_SDARDT_"~~~"_"Auto-rebook Date"
 ..S SDDAT=SDDAT_"|~~~"_SD8RD_"~~~"_"Resched Date"
 ..S SDDAT=SDDAT_"|~~~"_SDCDATE_"~~~"_"Consult Date"
 ..;S $P(SDSCH,U,12)=SDDAT,$P(SDSCH,U,26)=SDSTAT
 ..S @HL7XMIT@(CURLINE,1)=SDDAT_"^^^^^^^^^^^^^^"_SD25
 ..S CURLINE=CURLINE+1
 ..S @HL7XMIT@(CURLINE)=$$EN^VAFHLPID(DFN,"1,3,5,7,11,19",1,1)
 ..N SDCDFN S SDCDFN=$P(@HL7XMIT@(CURLINE),"^",4),SDCDFN=SDCDFN_"|"_DFN_"~~~USVHA&&L~PI" I $P(SDCDFN,"~")["V" S $P(SDCDFN,"~",2)=""
 ..S $P(@HL7XMIT@(CURLINE),"^",4)=SDCDFN
 ..N SDZIP S SDZIP=$P(@HL7XMIT@(CURLINE),U,12),SDZIP=$P(SDZIP,"~",5) S $P(@HL7XMIT@(CURLINE),U,12)="~~~~"_SDZIP
 ..S CURLINE=CURLINE+1
 ..;get Admission Type
 ..N SDCR1,SDAT,SDCR S SDCR1=$E(SDDAM,5,8)_$E(SDDAM,1,4) D DT^DILF(,SDCR1,.SDCR) S SDAT=$$POV^SDRPA20(DFN,SDADT,SDCL,SDCR)
 ..S @HL7XMIT@(CURLINE)="PV1^1^"_SDPATCL_"^^"_SDAT_"^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"_SDFAC
 ..S CURLINE=CURLINE+1
 ..S SDNEW=$S(SDNEW=1:"NSF",SDNEW=2:"OPN",SDNEW=3:"SHB")
 ..S @HL7XMIT@(CURLINE)="PV2^^^^^^^^^^^^^^^^^^^^^^^^"_SDNEW
 ..S CURLINE=CURLINE+1
 ..I $D(^TMP("SDDPT",$J,DFN,SDADT,"ROL")) D
 ...N SDCNT,SDAIP S SDAIP="AIP^" S SDCNT="" F  S SDCNT=$O(^TMP("SDDPT",$J,DFN,SDADT,"ROL",SDCNT)) Q:SDCNT=""  D
 ....N SDPOVID,SDPROVNM,SDROLS
 ....S SDROLS=^TMP("SDDPT",$J,DFN,SDADT,"ROL",SDCNT)
 ....S SDPOVID=$P(SDROLS,U,3),SDPROVNM=$P(SDROLS,U,4),SDPROVNM=$TR(SDPROVNM,",","~")
 ....S SDPROVNM=$TR(SDPROVNM," ","~")
 ....I $L(SDPROVNM,"~")=2 S SDPROVNM=SDPROVNM_"~~"
 ....E  I $L(SDPROVNM,"~")=3 S SDPROVNM=SDPROVNM_"~"
 ....S @HL7XMIT@(CURLINE)=SDAIP_SDCNT_"^^"_SDPOVID_"~"_SDPROVNM_"^"_"Provider"
 ....S CURLINE=CURLINE+1
 ..S @HL7XMIT@(CURLINE)="AIL^1^^"_SDCL_"~~~~~~~~"_SDCLNM_"^"_SDSTOP_"~"_SDSTOPD_"~DSS Clinic ID^"_SDCSTOP_"~"_SDCSTOPD_"~DSS Credit Stop"
 ..S CURLINE=CURLINE+1
 ..N SDCNT S SDCNT="" F  S SDCNT=$O(^TMP("SDDPT",$J,DFN,SDADT,"ZCL",SDCNT)) Q:SDCNT=""  D
 ...S @HL7XMIT@(CURLINE)=^TMP("SDDPT",$J,DFN,SDADT,"ZCL",SDCNT,0)
 ...S CURLINE=CURLINE+1
 ..;create ZEN only if enrollment was retrieved
 ..I SDENRO>0 S @HL7XMIT@(CURLINE)="ZEN^1^^^^^^^^"_SDENRO,CURLINE=CURLINE+1
 ..S @HL7XMIT@(CURLINE)="ZSP^1^"_SDSC_"^"_SDSCP
 ..S CURLINE=CURLINE+1
 ..;ZEL
 ..N SDZEL D EN1^VAFHLZEL(DFN,"1,37,38",1,.SDZEL) D
 ...;need to modify 37 WITH THE CREATION DATE
 ...N SDDAMV S SDDAMV=$$HL7TFM^XLFDT(SDDAM)
 ...N SDVC S SDVC=$$CVEDT^DGCV(DFN,SDDAMV),SDVC=$P(SDVC,"^",3) D
 ....S $P(SDZEL(1),"^",38)=$S(SDVC=1:1,SDVC=0:0,1:"U")
 ....I $P(SDZEL(1),"^",39)'?8N S $P(SDZEL(1),"^",39)=""
 ...S @HL7XMIT@(CURLINE)=SDZEL(1)
 ..S CURLINE=CURLINE+1
 ..;ZMH
 ..N SAR D ENTER^VAFHLZMH(DFN,"SAR","1,5,10","3,4",HL("FS"),HL("ECH"),"")
 ..S $P(SAR(1,0),"^",4)="" ;
 ..;service separation date
 ..;combat indication and location;gulf war indication
 ..S $P(SAR(1,0),"^",5)="~"_$P($P(SAR(1,0),"^",5),"~",2)
 ..N SS F SS=2,3 D
 ...S $P(SAR(SS,0),"^",5)=""
 ..I $E($P(SAR(2,0),"^",4))'="Y" S $P(SAR(2,0),"^",4)="N~"
 ..I $E($P(SAR(3,0),"^",4))'="Y" S $P(SAR(3,0),"^",4)="N"
 ..N SDD F SDD=1,2,3 S @HL7XMIT@(CURLINE)=SAR(SDD,0) S CURLINE=CURLINE+1
 ..;file MSGID into 409.69 separately as batch # and ID #
 ..N DIE,DA D
 ...S DIE="^SDWL(409.6,"_RUNID_",1,",DA(1)=RUNID
 ...S DA=$O(^SDWL(409.6,"AC",DFN,SDADT,RUNID,"")) D
 ....I $P(^SDWL(409.6,RUNID,1,DA,0),"^",3)'="" S DA=$O(^SDWL(409.6,"AC",DFN,SDADT,RUNID,DA))
 ...S DR="2///"_+MSGID_";3///"_$P(MSGID,"-",2) D ^DIE
 D GENERATE^HLMA("SD-PAIT-EVENT","GB",1,.HLRESLT,HLMTIEN,.HLP) K @HL7XMIT
 N DA,DIE,DR S DA=RUNID,DIE=409.6,DR="1.1///"_+$G(MSGID) D ^DIE
 S SDMCID=+$G(SDMCID)
 ;file message control ID # and batch control ID number
 N DIC,DA,X,Y D
 .S DIC="^SDWL(409.6,"_RUNID_",2,",DA(1)=RUNID,DIC("P")=409.7,DIC(0)="X"
 .S SDBCID=+$G(HLRESLT)
 .K DO S X=+$G(SDBCID) D FILE^DICN
 .S DA=+Y,DIE=DIC,DR=".02///"_+$G(SDDT)_";.03///"_+$G(SDA) D ^DIE
 Q