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

SCMCHLZ.m

Go to the documentation of this file. 
  1. SCMCHLZ ;BP/DJB - PCMM HL7 Bld ZPC Segment ; 3/7/00 1:08pm
  1.  ;;5.3;Scheduling;**177,210,212,245,286,515**;AUG 13, 1993;Build 14
  1.  ;
  1. ZPC(SCSTR,SCID,SCDATA,SCSEQ) ;Main entry point for building ZPC segment
  1.  ;
  1.  ;Input:
  1.  ;   SCSTR...: String of fields requested separated by commas
  1.  ;   SCID....: Provider Assignment ID. Unique ID string that
  1.  ;             Austin uses for the key field.
  1.  ;   SCDATA..: "^" Delimited string that contains all data needed
  1.  ;             to build a ZPC segment. If all pieces are "", Austin
  1.  ;             does a deletion.
  1.  ;               Format:
  1.  ;                 ProviderIEN^DateAssign^DateUnassign^Type
  1.  ;               Examples:
  1.  ;                 3^2980605^2990203^PCP
  1.  ;                 6^2980605^2990203^AP
  1.  ;                 ""^""^""^"" (deletion)
  1.  ;   SCSEQ...: Sequentially number multiple ZPC segments.
  1.  ;             djb/bp Patch 210.
  1.  ;Output:
  1.  ;   ZPC segment string.
  1.  ;
  1.  NEW CS,FS,QT,SCZPC,SS
  1.  ;
  1.  ;Initialize variables
  1.  D INIT
  1.  I $G(SCID)="" Q SCZPC
  1.  ;
  1.  I SCSTR[",1," D ID ;........Provider Assignment ID
  1.  I SCSTR[",2," D PROV ;......Provider
  1.  I SCSTR[",3," D PROVDA ;....Date provider assigned
  1.  I SCSTR[",4," D PROVDU ;....Date provider unassigned
  1.  I SCSTR[",5," D PROVT ;.....Provider Type code
  1.  I SCSTR[",6," D PROVPC ;....Provider Person Class  PATCH 515
  1.  I SCSTR[",8," D PROVSSN ;...Provider SSN;bp/ar and alb/rpm Patch 212
  1.  I SCSTR[",9," D STATION ;....5 or 6 digit station number Patch 286
  1.  I SCSTR[",10," D TEAM ;....Team Name - Patch 515
  1.  I SCSTR[",11," D TMIEN ;....Team IEN - Patch 515
  1.  I SCSTR[",16," D TMPUR ;...Team Purpose  Patch 515
  1.  I $L(SCZPC)>245 D ADJUST ;..If length>245 add continuation node
  1.  Q SCZPC
  1.  ;
  1. ID ;Provider Assignment ID
  1.  ;Convert ID to IEN of file 404.49 since it's alot shorter.
  1.  ;ID format:
  1.  ;  IEN404.43 - IEN404.52 - IEN404.53 - AP/PCP
  1.  ;  Examples: "2290-405-34-PCP"
  1.  ;            "2290-406-0-AP"
  1.  ;
  1.  NEW FAC,ID,OLDID,SCERR,SCFDA,SCIEN
  1.  ;
  1.  ;Find ID in PCMM HL7 ID file (404.49), and use IEN.
  1.  S ID=$O(^SCPT(404.49,"B",SCID,""))
  1.  ;
  1.  ;If ID not found, add it to 404.49 now.
  1.  I 'ID D  ;
  1.  . S SCFDA(404.49,"+1,",.01)=SCID
  1.  . D UPDATE^DIE("E","SCFDA","SCIEN","SCERR")
  1.  . S ID=$G(SCIEN(1))
  1.  ;
  1.  ;bp/djb Patch 210
  1.  ;New code begins
  1.  ;If this is a site integration entry, use old ID.
  1.  S FAC=SCFAC ;..Facility
  1.  S OLDID=$P($G(^SCPT(404.49,ID,0)),U,2)
  1.  I OLDID]"" D  ;
  1.  . S FAC=$P(OLDID,"-",1)
  1.  . S ID=$P(OLDID,"-",2)
  1.  ;New code ends
  1.  ;
  1.  ;Add ID to ZPC segment
  1.  S $P(SCZPC,FS,2)=FAC_"-"_ID
  1.  Q
  1.  ;
  1. STATION ; Add station # suffix patch SD*5.3*286
  1.  NEW STAT,SNUM,SCTP,TEAM,TEAMP
  1.  S $P(SCZPC,FS,10)=""
  1.  S SCTP=+$P(SCZPC,"-",2),SCTP=+$P($G(^SCPT(404.49,SCTP,0)),"-",1) D
  1.  .IF SCTP S TEAMP=$$GET1^DIQ(404.43,SCTP_",",.02,"I") D
  1.  ..IF TEAMP S SNUM=$$GET1^DIQ(404.57,TEAMP_",",.02,"I") D
  1.  ...IF SNUM S TEAM=$$GET1^DIQ(404.51,SNUM_",",.07,"I") D
  1.  ....IF TEAM S STAT=$$GET1^DIQ(4,TEAM_",",99) D
  1.  .....IF STAT S $P(SCZPC,FS,10)=STAT
  1.  Q
  1.  ;
  1. TEAM ;Add Team Name patch SD*5.3*515
  1.  NEW SNUM,SCTP,TEAM,TEAMP
  1.  S $P(SCZPC,FS,11)=QT
  1.  Q:'$L(($P(SCDATA,U,2)))
  1.  S SCTP=+$P(SCZPC,"-",2),SCTP=+$P($G(^SCPT(404.49,SCTP,0)),"-",1) D
  1.  .IF SCTP S TEAMP=$$GET1^DIQ(404.43,SCTP_",",.02,"I") D
  1.  ..IF TEAMP S SNUM=$$GET1^DIQ(404.57,TEAMP_",",.02,"I") D
  1.  ...IF SNUM S TEAM=$$GET1^DIQ(404.51,SNUM_",",.01,"I") D
  1.  ....IF $L(TEAM)>0 S $P(SCZPC,FS,11)=TEAM
  1.  Q
  1.  ;
  1. TMIEN ;Add Team IEN patch SD*5.3*515
  1.  NEW SNUM,SCTP,TEAMP
  1.  S $P(SCZPC,FS,12)=QT
  1.  Q:'$L(($P(SCDATA,U,2)))
  1.  S SCTP=+$P(SCZPC,"-",2),SCTP=+$P($G(^SCPT(404.49,SCTP,0)),"-",1) D
  1.  .IF SCTP S TEAMP=$$GET1^DIQ(404.43,SCTP_",",.02,"I") D
  1.  ..IF TEAMP S SNUM=$$GET1^DIQ(404.57,TEAMP_",",.02,"I") D
  1.  ...IF SNUM S $P(SCZPC,FS,12)=SNUM
  1.  Q
  1.  ;
  1. PROV ;Provider
  1.  NEW PROV,PTR200,SCNAM,SCNAME,SCTMP,X
  1.  ;
  1.  S $P(SCZPC,FS,3)=QT
  1.  S PTR200=+SCDATA
  1.  Q:'PTR200
  1.  ;
  1.  ;Get External Provider ID
  1.  D PERSON^VAFHLRO3(PTR200,"SCTMP",QT)
  1.  Q:'$D(SCTMP)
  1.  S PROV=SCTMP(1,1,1)_SS_SCTMP(1,1,2)
  1.  S $P(PROV,CS,8)=SCTMP(1,8)
  1.  ;rpm/alb patch 210-Stuff facility in Assigning Facility(component 14)
  1.  S $P(PROV,CS,14)=SCTMP(1,1,2)
  1.  ;rpm/alb patch 210
  1.  ;Get Standardized Name using Kernel API
  1.  ;Standardized Name retrieval allowed by IA #3065
  1.  S SCNAM("FILE")=200
  1.  S SCNAM("IENS")=PTR200_","
  1.  S SCNAM("FIELD")=.01
  1.  S SCNAME=$$HLNAME^XLFNAME(.SCNAM,"",FS)
  1.  F X=2:1:7 S $P(PROV,CS,X)=$P(SCNAME,FS,X-1)
  1.  F X=9:1:13 S $P(PROV,CS,X)=""
  1.  ;
  1.  ;Add provider to ZPC segment
  1.  S $P(SCZPC,FS,3)=PROV
  1.  Q
  1.  ;
  1. PROVDA ;Provider - Date Assigned
  1.  NEW DATE
  1.  S $P(SCZPC,FS,4)=QT
  1.  S DATE=$P(SCDATA,U,2)
  1.  Q:'DATE
  1.  S $P(SCZPC,FS,4)=$$HLDATE^HLFNC(DATE,"DT")
  1.  Q
  1.  ;
  1. PROVDU ;Provider - Date Unassigned
  1.  NEW DATE
  1.  S $P(SCZPC,FS,5)=QT
  1.  S DATE=$P(SCDATA,U,3)
  1.  Q:'DATE
  1.  S $P(SCZPC,FS,5)=$$HLDATE^HLFNC(DATE,"DT")
  1.  Q
  1.  ;
  1. PROVT ;Provider - Type code
  1.  NEW PT
  1.  S $P(SCZPC,FS,6)=QT
  1.  S PT=$P(SCDATA,U,4)
  1.  Q:PT']""
  1.  S $P(SCZPC,FS,6)=PT
  1.  Q
  1.  ;
  1. PROVPC ;Provider - Person Class
  1.  NEW CODE,PTR200
  1.  S $P(SCZPC,FS,7)=QT
  1.  S PTR200=+SCDATA
  1.  Q:'PTR200
  1.  S CODE=$$GET^XUA4A72(PTR200)
  1.  ; PATCH 515  OLD CODE
  1.  ; I CODE=-1!'CODE Q
  1.  ; S $P(SCZPC,FS,7)=$P(CODE,"^",7)_CS_CS_"VA8932.1"
  1.  I CODE=-1!'CODE S CODE=""
  1.  S CODE=$P(CODE,"^",7)
  1.  S $P(SCZPC,FS,7)=CODE_CS_CS_"VA8932.1"
  1.  Q
  1.  ;
  1. PROVSSN ;Provider - Social Security Number
  1.  ;bp/ar and alb/rpm Patch 212
  1.  NEW SCSNN,PTR200,SC200,SCARRY
  1.  S $P(SCZPC,FS,9)=QT
  1.  S PTR200=+SCDATA
  1.  Q:'PTR200
  1.  S SC200=$$NEWPERSN^SCMCGU(PTR200,"SCARRY")
  1.  I SC200'=1 Q
  1.  S SCSNN=$P($G(SCARRY(PTR200)),U,6)
  1.  Q:SCSNN'?9N
  1.  S $P(SCZPC,FS,9)=SCSNN
  1.  Q
  1.  ;
  1. TMPUR ; TEAM PURPOSE ADDED PATCH 515 send in BOTH DELETE & ADD
  1.  S $P(SCZPC,FS,17)=QT
  1.  ; Q:SCDATA="^^^"   COMMENT OUT SO SEND W DELETE TOO
  1.  NEW SCTMPI,SCTMP,SCTPD,SCTM,TMD,ND,SCTP
  1.  ; Read PATIENT TEAM ASS FILE 
  1.  S ND=$G(^SCPT(404.43,$P(SCID,"-",1),0))
  1.  Q:ND=""
  1.  S SCTP=$P(ND,U,2)   ; TP
  1.  ; READ TP REC (57)
  1.  S SCTPD=$G(^SCTM(404.57,SCTP,0))
  1.  Q:SCTPD=""
  1.  S SCTM=$P(SCTPD,U,2)
  1.  ; READ TEAM FILE (404.51
  1.  S TMD=^SCTM(404.51,SCTM,0)
  1.  S SCTMP=$P(TMD,U,3)
  1.  Q:SCTMP=""
  1.  S SCTMPI=SCTMP
  1.  S SCTMP=$G(^SD(403.47,SCTMP,0))
  1.  Q:SCTMP=""
  1.  S SCTMP=$P(SCTMP,U,1)
  1.  Q:SCTMP=""
  1.  S $P(SCZPC,FS,17)=SCTMPI_CS_SCTMP
  1.  Q
  1.  ;
  1. INIT ;Initialize variables
  1.  ;
  1.  ;Set delimeter values
  1.  S FS=HL("FS") ;.........^
  1.  S CS=$E(HL("ECH"),1) ;..~
  1.  S SS=$E(HL("ECH"),4) ;..&
  1.  S QT=HL("Q") ;..........""
  1.  ;
  1.  ;Default SCSEQ to 1. djb/bp Patch 210
  1.  S:'$G(SCSEQ) SCSEQ=1
  1.  ;
  1.  ;Initialize ZPC segment to all nulls.
  1.  ;bp/ar and alb/rpm Patch 212
  1.  ;S $P(SCZPC,FS,5)="^" ;Initialize as empty; not null.
  1.  ;S SCZPC="ZPC"_FS_SCZPC_FS_SCSEQ ;djb/bp Patch 210
  1.  S $P(SCZPC,FS,9)=""
  1.  S $P(SCZPC,FS,10)="" ; PATCH 286
  1.  S $P(SCZPC,FS,11)="" ; PATCH 515
  1.  S $P(SCZPC,FS,12)="" ; PATCH 515
  1.  ; DEBBIE LEVY TPA CHGS 20070518 PATCH 515
  1.  S $P(SCZPC,FS,17)=""
  1.  S $P(SCZPC,FS,1)="ZPC"
  1.  S $P(SCZPC,FS,8)=SCSEQ
  1.  ;
  1.  ;Initialize SCSTR to fields user requested.
  1.  S SCSTR=$G(SCSTR)
  1.  ;bp/ar and alb/rpm Added "8" to default fields Patch 212
  1.  ; Added "9" to default fields Patch 286
  1.  ; DEBBIE LEVY TPA CHGS 20070518 PATCH 515
  1.  ;     added team (10), team IEN (11) and team purpose (16)
  1.  ;I SCSTR']"" S SCSTR="1,2,3,4,5,6,8,9" ;Default fields
  1.  I SCSTR']"" S SCSTR="1,2,3,4,5,6,8,9,10,11,16" ;Default fields
  1.  ;Add starting and ending comma.
  1.  I $E(SCSTR)'="," S SCSTR=","_SCSTR
  1.  I $E(SCSTR,$L(SCSTR))'="," S SCSTR=SCSTR_","
  1.  Q
  1.  ;
  1. ADJUST ;Add a continuation node if length is greater than 245.
  1.  Q:$L(SCZPC)'>245
  1.  S SCZPC(1)=$E(SCZPC,246,999) ;
  1.  S SCZPC=$E(SCZPC,1,245)
  1.  Q