SCMCHLB1 ;BPOI/DJB - PCMM HL7 Bld Segment Array Cont.;8/17/99
;;5.3;Scheduling;**177,515,524**;08/17/99;Build 29
;
SEGMENTS(DFN,SUB) ;Build EVN & PID segments
;Input:
; DFN - Patient IEN
; SUB - Value for 1st Subscript
;Output:
; XMITARRY() - Array of EVN & PID segments
;
NEW LINETAG,SEGMENTS,SEGNAME,SEGORD
NEW EVNTDATE,EVNTHL7,VAFARRY,VAFEVN,VAFPID,VAFSTR
;
;Initialize variables
Q:'$G(DFN) ;Required for PID segment
Q:'$G(SUB)
S EVNTDATE=DT
S EVNTHL7="A08"
;
;Get array of segments to be built
D SEGMENTS^SCMCHLS(EVNTHL7,"SEGMENTS")
;
;Loop thru segments array. Ignore ZPC segment - already built.
S SEGORD=0
F S SEGORD=+$O(SEGMENTS(SEGORD)) Q:'SEGORD D ;
. S SEGNAME=""
. F S SEGNAME=$O(SEGMENTS(SEGORD,SEGNAME)) Q:SEGNAME="" D ;
.. Q:SEGNAME="ZPC" ;.................ZPC already built
.. S VAFSTR=SEGMENTS(SEGORD,SEGNAME) ;String of segment fields
.. S LINETAG="BLD"_SEGNAME
.. D @LINETAG^SCMCHLS ;...............Build segment
.. S LINETAG="CPY"_SEGNAME
.. D @LINETAG^SCMCHLS ;...............Copy segment into array
Q
;
ZPC(ARRAY,DELETE) ;Loop thru array and build array of ZPC segments.
;
;Input:
; ARRAY - Array to be processed. This array was built in ^SCMCHLB
; with calls to $$PRTPC^SCAPMC() and $$PRPTTPC^SCAPMC().
; Examples:
; ARRAY(2290,"PCP","2290-406-34-PCP")= Data
; ARRAY(345,"PROV-P","2290-405-0-AP")= Data
; DELETE - 1=Process a delete type ZPC segment (all fields null)
;Output:
; Array of ZPC segments
;
NEW DATA,DATE,ID,ID1,LINETAG,SUB,TYPE,VAFZPC
;
S SUB=0
F S SUB=$O(ARRAY(SUB)) Q:'SUB D ;
. S TYPE=""
. F S TYPE=$O(ARRAY(SUB,TYPE)) Q:TYPE="" D ;
.. S ID=""
.. F S ID=$O(ARRAY(SUB,TYPE,ID)) Q:ID="" D ;
... S DATA=$G(ARRAY(SUB,TYPE,ID))
... I $G(DELETE) S DATA="^^^" ;A Delete type ZPC segment
... E D ;....................A ZPC segment with data
.... ;Get dates
.... S DATE(9)=$P(DATA,U,9)
.... S DATE(10)=$P(DATA,U,10)
.... S DATE(14)=$P(DATA,U,14) ;Preceptor start date
.... S DATE(15)=$P(DATA,U,15) ;Preceptor end date
.... I DATE(14),DATE(14)>DATE(9) S DATE(9)=DATE(14)
.... I DATE(15) D ;
..... I 'DATE(10) S DATE(10)=DATE(15) Q
..... I DATE(15)<DATE(10) S DATE(10)=DATE(15)
.... ;
.... ;Provider^AssignDate^UnassignDate^ProviderType
.... S DATA=$P(DATA,U,1)_"^"_DATE(9)_"^"_DATE(10)
....; PATCH 515 DLL ADD NEW ROLES (TPA,CCM,PM)
....; OLD CODE = S DATA=DATA_"^"_$S(ID["AP":"AP",1:"PCP")
....S ROLE=$P(ID,"-",4) I $G(ROLE)="" S ROLE="PCP"
....S DATA=DATA_"^"_ROLE
... ;
... D BLDZPC^SCMCHLS ;..Build segment ; og/sd/524
... D CPYZPC^SCMCHLS ;..Copy segment into array ; og/sd/524
Q
;
DFN(ND) ;Find DFN from zero node of Patient Team Position Assign (404.43).
;Input:
; ND - Zero node of 404.43
;Output:
; DFN - Patient IEN
; "" - No valid DFN found
;
S DFN=$P(ND,U,1)
I DFN S DFN=$P($G(^SCPT(404.42,DFN,0)),U,1)
Q DFN
;
ADJID(ARRAY,SCIEN) ;Adjust ID to include Pt Tm Pos Assign pointer
;Example: From this: 424-34-AP
; To this: 2290-424-34-AP
;Input:
; ARRAY - Array to be processed
; SCIEN - 404.43 IEN to be added to ID
;
NEW ADJID,ID,NUM,TMP,TYPE
;
;Build TMP() array using adjusted ID
S NUM=0
F S NUM=$O(ARRAY(NUM)) Q:'NUM D ;
. S TYPE=""
. F S TYPE=$O(ARRAY(NUM,TYPE)) Q:TYPE="" D ;
.. S ID=""
.. F S ID=$O(ARRAY(NUM,TYPE,ID)) Q:ID="" D ;
... S ADJID=SCIEN_"-"_ID ;..Add 404.43 IEN
... S TMP(NUM,TYPE,ADJID)=ARRAY(NUM,TYPE,ID)
;
;Replace ARRAY() with adjusted TMP() array.
Q:'$D(TMP)
KILL ARRAY
M ARRAY=TMP ;Copy TMP() into ARRAY()
Q
;
CHECK(VARPTR) ;Validate event variable pointer.
;Input:
; VARPTR - EVENT POINTER field of PCMM HL7 EVENT (#404.48)
;Output:
; SCIEN - IEN portion of variable pointer
; SCGLB - Global portion of variable pointer
;Return:
; 0: Invalid variable pointer format
; 1: Valid pointer
; 2: No data. Entry has been deleted. Send a delete to NPCD.
;
NEW CHK,GLB
;
S SCIEN=$P(VARPTR,";") ;....IEN portion of variable pointer
S SCGLB=$P(VARPTR,";",2) ;..Global portion of variable pointer
;
;Return zero if variable pointer is invalid.
I 'SCIEN Q 0
S CHK=0 D I CHK Q 0
. Q:SCGLB="SCPT(404.43,"
. Q:SCGLB="SCTM(404.52,"
. Q:SCGLB="SCTM(404.53,"
. S CHK=1
;
;Is there data for this IEN?
S GLB="^"_SCGLB_SCIEN_",0)"
I '$D(@GLB) Q 2 ;..Entry has been deleted
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCHLB1 4567 printed Sep 23, 2025@20:16:47 Page 2
SCMCHLB1 ;BPOI/DJB - PCMM HL7 Bld Segment Array Cont.;8/17/99
+1 ;;5.3;Scheduling;**177,515,524**;08/17/99;Build 29
+2 ;
SEGMENTS(DFN,SUB) ;Build EVN & PID segments
+1 ;Input:
+2 ; DFN - Patient IEN
+3 ; SUB - Value for 1st Subscript
+4 ;Output:
+5 ; XMITARRY() - Array of EVN & PID segments
+6 ;
+7 NEW LINETAG,SEGMENTS,SEGNAME,SEGORD
+8 NEW EVNTDATE,EVNTHL7,VAFARRY,VAFEVN,VAFPID,VAFSTR
+9 ;
+10 ;Initialize variables
+11 ;Required for PID segment
if '$GET(DFN)
QUIT
+12 if '$GET(SUB)
QUIT
+13 SET EVNTDATE=DT
+14 SET EVNTHL7="A08"
+15 ;
+16 ;Get array of segments to be built
+17 DO SEGMENTS^SCMCHLS(EVNTHL7,"SEGMENTS")
+18 ;
+19 ;Loop thru segments array. Ignore ZPC segment - already built.
+20 SET SEGORD=0
+21 ;
FOR
SET SEGORD=+$ORDER(SEGMENTS(SEGORD))
if 'SEGORD
QUIT
Begin DoDot:1
+22 SET SEGNAME=""
+23 ;
FOR
SET SEGNAME=$ORDER(SEGMENTS(SEGORD,SEGNAME))
if SEGNAME=""
QUIT
Begin DoDot:2
+24 ;.................ZPC already built
if SEGNAME="ZPC"
QUIT
+25 ;String of segment fields
SET VAFSTR=SEGMENTS(SEGORD,SEGNAME)
+26 SET LINETAG="BLD"_SEGNAME
+27 ;...............Build segment
DO @LINETAG^SCMCHLS
+28 SET LINETAG="CPY"_SEGNAME
+29 ;...............Copy segment into array
DO @LINETAG^SCMCHLS
End DoDot:2
End DoDot:1
+30 QUIT
+31 ;
ZPC(ARRAY,DELETE) ;Loop thru array and build array of ZPC segments.
+1 ;
+2 ;Input:
+3 ; ARRAY - Array to be processed. This array was built in ^SCMCHLB
+4 ; with calls to $$PRTPC^SCAPMC() and $$PRPTTPC^SCAPMC().
+5 ; Examples:
+6 ; ARRAY(2290,"PCP","2290-406-34-PCP")= Data
+7 ; ARRAY(345,"PROV-P","2290-405-0-AP")= Data
+8 ; DELETE - 1=Process a delete type ZPC segment (all fields null)
+9 ;Output:
+10 ; Array of ZPC segments
+11 ;
+12 NEW DATA,DATE,ID,ID1,LINETAG,SUB,TYPE,VAFZPC
+13 ;
+14 SET SUB=0
+15 ;
FOR
SET SUB=$ORDER(ARRAY(SUB))
if 'SUB
QUIT
Begin DoDot:1
+16 SET TYPE=""
+17 ;
FOR
SET TYPE=$ORDER(ARRAY(SUB,TYPE))
if TYPE=""
QUIT
Begin DoDot:2
+18 SET ID=""
+19 ;
FOR
SET ID=$ORDER(ARRAY(SUB,TYPE,ID))
if ID=""
QUIT
Begin DoDot:3
+20 SET DATA=$GET(ARRAY(SUB,TYPE,ID))
+21 ;A Delete type ZPC segment
IF $GET(DELETE)
SET DATA="^^^"
+22 ;....................A ZPC segment with data
IF '$TEST
Begin DoDot:4
+23 ;Get dates
+24 SET DATE(9)=$PIECE(DATA,U,9)
+25 SET DATE(10)=$PIECE(DATA,U,10)
+26 ;Preceptor start date
SET DATE(14)=$PIECE(DATA,U,14)
+27 ;Preceptor end date
SET DATE(15)=$PIECE(DATA,U,15)
+28 IF DATE(14)
IF DATE(14)>DATE(9)
SET DATE(9)=DATE(14)
+29 ;
IF DATE(15)
Begin DoDot:5
+30 IF 'DATE(10)
SET DATE(10)=DATE(15)
QUIT
+31 IF DATE(15)<DATE(10)
SET DATE(10)=DATE(15)
End DoDot:5
+32 ;
+33 ;Provider^AssignDate^UnassignDate^ProviderType
+34 SET DATA=$PIECE(DATA,U,1)_"^"_DATE(9)_"^"_DATE(10)
+35 ; PATCH 515 DLL ADD NEW ROLES (TPA,CCM,PM)
+36 ; OLD CODE = S DATA=DATA_"^"_$S(ID["AP":"AP",1:"PCP")
+37 SET ROLE=$PIECE(ID,"-",4)
IF $GET(ROLE)=""
SET ROLE="PCP"
+38 SET DATA=DATA_"^"_ROLE
End DoDot:4
+39 ;
+40 ;..Build segment ; og/sd/524
DO BLDZPC^SCMCHLS
+41 ;..Copy segment into array ; og/sd/524
DO CPYZPC^SCMCHLS
End DoDot:3
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
DFN(ND) ;Find DFN from zero node of Patient Team Position Assign (404.43).
+1 ;Input:
+2 ; ND - Zero node of 404.43
+3 ;Output:
+4 ; DFN - Patient IEN
+5 ; "" - No valid DFN found
+6 ;
+7 SET DFN=$PIECE(ND,U,1)
+8 IF DFN
SET DFN=$PIECE($GET(^SCPT(404.42,DFN,0)),U,1)
+9 QUIT DFN
+10 ;
ADJID(ARRAY,SCIEN) ;Adjust ID to include Pt Tm Pos Assign pointer
+1 ;Example: From this: 424-34-AP
+2 ; To this: 2290-424-34-AP
+3 ;Input:
+4 ; ARRAY - Array to be processed
+5 ; SCIEN - 404.43 IEN to be added to ID
+6 ;
+7 NEW ADJID,ID,NUM,TMP,TYPE
+8 ;
+9 ;Build TMP() array using adjusted ID
+10 SET NUM=0
+11 ;
FOR
SET NUM=$ORDER(ARRAY(NUM))
if 'NUM
QUIT
Begin DoDot:1
+12 SET TYPE=""
+13 ;
FOR
SET TYPE=$ORDER(ARRAY(NUM,TYPE))
if TYPE=""
QUIT
Begin DoDot:2
+14 SET ID=""
+15 ;
FOR
SET ID=$ORDER(ARRAY(NUM,TYPE,ID))
if ID=""
QUIT
Begin DoDot:3
+16 ;..Add 404.43 IEN
SET ADJID=SCIEN_"-"_ID
+17 SET TMP(NUM,TYPE,ADJID)=ARRAY(NUM,TYPE,ID)
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ;Replace ARRAY() with adjusted TMP() array.
+20 if '$DATA(TMP)
QUIT
+21 KILL ARRAY
+22 ;Copy TMP() into ARRAY()
MERGE ARRAY=TMP
+23 QUIT
+24 ;
CHECK(VARPTR) ;Validate event variable pointer.
+1 ;Input:
+2 ; VARPTR - EVENT POINTER field of PCMM HL7 EVENT (#404.48)
+3 ;Output:
+4 ; SCIEN - IEN portion of variable pointer
+5 ; SCGLB - Global portion of variable pointer
+6 ;Return:
+7 ; 0: Invalid variable pointer format
+8 ; 1: Valid pointer
+9 ; 2: No data. Entry has been deleted. Send a delete to NPCD.
+10 ;
+11 NEW CHK,GLB
+12 ;
+13 ;....IEN portion of variable pointer
SET SCIEN=$PIECE(VARPTR,";")
+14 ;..Global portion of variable pointer
SET SCGLB=$PIECE(VARPTR,";",2)
+15 ;
+16 ;Return zero if variable pointer is invalid.
+17 IF 'SCIEN
QUIT 0
+18 SET CHK=0
Begin DoDot:1
+19 if SCGLB="SCPT(404.43,"
QUIT
+20 if SCGLB="SCTM(404.52,"
QUIT
+21 if SCGLB="SCTM(404.53,"
QUIT
+22 SET CHK=1
End DoDot:1
IF CHK
QUIT 0
+23 ;
+24 ;Is there data for this IEN?
+25 SET GLB="^"_SCGLB_SCIEN_",0)"
+26 ;..Entry has been deleted
IF '$DATA(@GLB)
QUIT 2
+27 QUIT 1
