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