SCMCHLB ;BP/DJB - PCMM HL7 Bld Segment Array ; 3/2/00 2:12pm
;;5.3;Scheduling;**177,204,210,224,515,532**;AUG 13, 1993;Build 21
;
BUILD(VARPTR,HL,XMITARRY) ;Build an array of HL7 segments based on EVENT
;POINTER field in PCMM HL7 EVENT file (#404.48).
;
;Input:
; VARPTR - EVENT POINTER field in PCMM HL7 EVENT file.
; HL - Array of HL7 variables (pass by reference).
; Output of call to INIT^HLFNC2().
; XMITARRY - Array to store HL7 segments (full global ref).
; Default=^TMP("HLS",$J)
;Output:
; XMITARRY(n,segment) array of segments.
; Examples:
; ^TMP("PCMM","HL7",$J,2290,"PID")...= PID segment
; ^TMP("PCMM","HL7",$J,2290,"ZPC",ID)= ZPC segments
; -1^Error = Unable to build message / bad input
;
;Note: The calling program must initialize (i.e. KILL) XMITARRY.
;
;Declare variables
NEW RESULT,SCIEN,SCGLB
NEW HLECH,HLEID,HLFS,HLQ
;
;Convert VARPTR (ien;global) to SCIEN & SCGLB
S RESULT=$$CHECK^SCMCHLB1($G(VARPTR))
;
I 'RESULT Q "-1^Did not pass valid variable pointer"
;
;Initialize HL7 variables
S HLECH=HL("ECH")
S HLFS=HL("FS")
S HLQ=HL("Q")
;
I RESULT=2 D G QUIT ;........................Process a deletion
. I SCGLB="SCPT(404.43," D PTP^SCMCHLB2 Q ;..Delete - File 404.43
. I SCGLB="SCTM(404.52," D POS^SCMCHLB2 Q ;..Delete - File 404.52
. I SCGLB="SCTM(404.53," D PRE^SCMCHLB2 Q ;..Delete - File 404.53
I SCGLB="SCPT(404.43," D PTP(SCIEN,"") G QUIT ;..File 404.43
I SCGLB="SCTM(404.52," D POS G QUIT ;.........File 404.52
I SCGLB="SCTM(404.53," D PRE G QUIT ;.........File 404.53
QUIT Q 1
;
;==================================================================
;
PTP(PTPI,SCTPAIN) ;Patient Team Position Assignment (#404.43).
;Input: PTPI - Patient Team Position Assignment IEN
;
;To keep VISTA and NPCD in sync, for this PT TM POS ASSIGN send
;down a delete for all previous entries, and then send down data
;for current valid entries.
;
;NEW DFN,ERROR,ND,ZDATE,ZPTP
;djb/bp Added SCSEQ per Patch 210, replace above line with below line
;NEW DFN,ERROR,ND,SCSEQ,ZDATE,ZPTP
; ADDED SCLOW SCTPTPA PATCH 515 DLL
NEW DFN,ERROR,ND,SCSEQ,ZDATE,ZPTP,SCLOW,SCTPTPA
;
;Get data
S ND=$G(^SCPT(404.43,PTPI,0))
S DFN=$$DFN^SCMCHLB1(ND) Q:'DFN ;..Patient
;
;Get only valid entries for this PT TM POS ASSIGN. This call returns
;provider array for a patient team position assignment.
;Example: ZPTP(8944,"AP","8944-909-0-AP")=data
; ZPTP(8944,"PCP","8944-911-157-PCP")=data
KILL ZPTP
D SETDATE ;Set date array
S RESULT=$$PRPTTPC^SCAPMC(PTPI,"ZDATE","ZPTP","ERROR","",1)
; add check if primary PATCH 515 BEGIN
; S SCTPTPA=$$TPACHK("",PTPI,SCTPAIN
S SCTPTPA=$$TPACHK("",PTPI,"")
; If not primary then call GETOEF to find others
S SCLOW=PTPI
;REMOVED IF SCTPTPA=1/532/TEH at first, now it's back in
IF SCTPTPA=1 S SCLOW=$$GETOEF(PTPI,"","")
; PATCH 515 END
;
;If no valid history don't build any segments
Q:'$D(ZPTP)
;
;Build EVN & PID segments
D SEGMENTS^SCMCHLB1(DFN,PTPI)
;
;Generate deletes for all ID's starting with this PT TM POS ASSIGN.
; PATCH 515 - CHG ALWAYS DELETE TO NOT IF TPA
; OLD CODE = D PTPD^SCMCHLB2(PTPI)
IF SCTPTPA'=1 S NUM=PTPI D PTPD^SCMCHLB2(PTPI)
;
;Build data type ZPC segments.
D ZPC^SCMCHLB1(.ZPTP)
;alb/rpm;Patch 224 Decrement max msg counter
I $D(SCLIMIT) S SCLIMIT=SCLIMIT-1
Q
;
POS ;Position Assign History (#404.52)
;
;To keep VISTA and NPCD in sync, for every primary care entry in Pt
;Tm Pos Assign for this TEAM POSITION, send down all valid entries.
;
NEW TMPOS,TP
;
;Team Position pointer
S TMPOS=$P($G(^SCTM(404.52,SCIEN,0)),U,1)
Q:'TMPOS
;
;Get History entries for each PT TM POS ASSIGN
D POS1(TMPOS)
;
;What if this TEAM POSITION is also a preceptor? Find every TEAM
;POSITION being precepted by this TEAM POSITION and for each, find
;every PT TM POS ASSIGN and send down all valid History entries.
;
S TP=0
F S TP=$O(^SCTM(404.53,"AD",TMPOS,TP)) Q:'TP D POS1(TP)
Q
;
POS1(TMPOS) ;Find every primary care PT TM POS ASSIGN for this TEAM POSITION
;and get all valid History entries.
;Input:
; TMPOS - TEAM POSITION pointer
;
Q:'$G(TMPOS)
NEW IFN,ND,TM,SCTPTPA
S SCTPTPA=$$TPACHK(TMPOS,"","")
;
; ..; PTA CHG 20070518 SD*5.3*515
; OLD CODE = S TM=0 (WAS MISSING PEOPLE)
S TM=""
F S TM=$O(^SCPT(404.43,"APTPA",TMPOS,TM)) Q:'TM D ;
. S IFN=0
. F S IFN=$O(^SCPT(404.43,"APTPA",TMPOS,TM,IFN)) Q:'IFN D ;
.. S ND=$G(^SCPT(404.43,IFN,0))
..; Q:($P(ND,U,5)'=1) ; Must be Primary Care
..; PTA CHG 20070518 SD*5.3*515
..Q:(($P(ND,U,5)'=1)&(SCTPTPA=0)) ; Must be Primary Care OR PTA
..; D PTP(IFN,SCTPTPA) ;..........Bld segments for this PT TM POS ASSIGN
..D PTP(IFN,"") ;..........Bld segments for this PT TM POS ASSIGN
Q
;
PRE ;Preceptor Assign History (#404.53)
;
;Get TEAM POSITION pointer of preceptee. Find every primary care
;PT TM POS ASSIGN for this TEAM POSITION and send down all valid
;History entries.
;
NEW TMPOS
;
;Preceptee TEAM POSITION pointer
S TMPOS=$P($G(^SCTM(404.53,SCIEN,0)),U,1)
Q:'TMPOS
D POS1(TMPOS) ;Get History entries for each PT TM POS ASSIGN
;
;Preceptor TEAM POSITION pointer
S TMPOS=$P($G(^SCTM(404.53,SCIEN,0)),U,6)
Q:'TMPOS
D POS1(TMPOS) ;Get History entries for each PT TM POS ASSIGN
Q
;
SETDATE ;Set all encompassing date array
S ZDATE("BEGIN")=2800101
S ZDATE("END")=9991231
S ZDATE("INCL")=0
Q
TPACHK(SCTP,SCPTPI,SCROLEP) ; CHECK IF TEAM POSITION IS A PTA
; levyd 20070518 SD*5.3*515
;Get data FROM 43
NEW ND,SCPC,SCTPD,SCTPX,SCROL,SCTM,SCTPA,TMD,SCTMP,SCTPTA,SCTPA,SCROLX,SCPURX,SCUP,SCLOW,SCROLY
S SCTPA=0
S SCPURX="OIF OEF"
S SCROLX="/TPA/PM/CCM/"
S SCUP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
S SCLOW="abcdefghijklmnopqrstuvwxyz"
I $L(SCPTPI) D ;
.S ND=$G(^SCPT(404.43,SCPTPI,0))
.; DEBBIE LEVY PTA CHGS 20070518
.; PRIMARY CARE ROLE CHECK
.IF $L(ND) S SCPC=$P(ND,U,5) D ;
..IF SCPC'=1 S SCTP=$P(ND,U,2) ; TP
; READ TP REC (57)
IF SCTP="" Q SCTPA
S SCTPD=$G(^SCTM(404.57,SCTP,0))
S SCTPX=$P(SCTPD,U,4) ;not primary
IF SCTPX=1 Q SCTPA
S SCROL=$P(SCTPD,U,3)
S SCROL=$P(^SD(403.46,SCROL,0),U,1)
IF $G(SCROLEP)=1 S SCROL=$$TPACHGRL(SCROL) Q SCROL
IF $G(SCROLEP)="" S SCROL=$$TPACHGRL(SCROL)
S SCTM=$P(SCTPD,U,2)
S SCROLY="/"_SCROL_"/"
S SCTPA=0 I SCROLX[SCROLY S SCTPA=1 ; OEF ROLE
; READ TEAM FILE (404.51
S TMD=^SCTM(404.51,SCTM,0)
S SCTMP=$P(TMD,U,3)
S SCTMP=^SD(403.47,SCTMP,0)
; CONVERT STR LOWER CASE TO UPPER CASE
S SCTMP=$TR(SCTMP,SCLOW,SCUP)
S SCTPTA=0 I SCTMP[SCPURX S SCTPTA=1
I ((SCTPA=1)&(SCTPTA=1)) S SCTPA=1
QT Q SCTPA
;
GETOEF(PTPI,EFFDT,ENDDT) ;Find All OIF OEF RELATIONSHIPS FOR THIS TP in TPS array
; NEW RTN ADDED W PATCH 515 BY DLL
;Input: TP - Team Position IEN
; EFFDT = Team Position EFFECTIVE DATE (OPTIONAL)
; ENDDT = Team Position EXPIRATION DATE (OPTIONAL)
NEW TP,COUNT,TPD,TPX,TPDX,TPXX,TPDXX,SCOLDPAT,SCOLDTM,SCOLDTP,SCLOW,DFNX,DFNY
S SCLOW=PTPI
IF ENDDT="" S ENDDT=9991231
K SCTPS,SCPCP
; save original trigger TP, person and team
S SCOLD43I=PTPI
;Get data
S ND=$G(^SCPT(404.43,PTPI,0))
S DFNY=$P(ND,U,1)
S DFNX=$G(^SCPT(404.42,DFNY,0))
S SCOLDTP=$P(ND,U,2)
S SCOLDPAT=$P(DFNX,U,1)
S SCOLDTM=$P(DFNX,U,3)
; read thru the patient assignments for this person in 42 ^SCPT(404.42,"B",3994,6930)
S TPX=""
S COUNT=0
F S TPX=$O(^SCPT(404.42,"B",SCOLDPAT,TPX)) Q:'TPX D
. S TPDX=$G(^SCPT(404.42,TPX,0))
. Q:$P(TPDX,U,3)'=SCOLDTM ;MUST be SAME TEAM
. ; red thru the the assignments for this patient ass in 43 ^SCPT(404.43,"B",6930
.S TPXX=""
.F S TPXX=$O(^SCPT(404.43,"B",TPX,TPXX)) Q:'TPXX D
..S TPDXX=$G(^SCPT(404.43,TPXX,0))
..S TP=$P(TPDXX,U,2)
..IF $G(SCPCP(TP))'=1 D ; TP NOT THERE ALREADY THEN ADD IT TO SCTPS
...S COUNT=COUNT+1
...S SCTPS(COUNT)=TP
...S SCPCP(TP)=1
...IF TP'=SCOLDTP D
....S RESULT=$$PRPTTPC^SCAPMC(TPXX,"ZDATE","ZPTP","ERROR","",1)
S SCLOW=$$TPAIDS(.ZPTP,.PTPI)
Q SCLOW
TPACHGRL(SCROLEIN) ;ROLE ABBREVIATION
NEW SCUP,SCLOW,SCPURX
S SCPURX="OIF OEF"
S SCROLOUT=""
Q:$L($G(SCROLEIN))=0
S SCUP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
S SCLOW="abcdefghijklmnopqrstuvwxyz"
; CONVERT STR LOWer case TO UPper case
S SCROLEIN=$TR(SCROLEIN,SCLOW,SCUP)
IF (SCROLEIN["TRANSITION PATIENT ADV")&(SCROLEIN[SCPURX) S SCROLOUT="TPA"
IF (SCROLEIN["PROGRAM MANA")&(SCROLEIN[SCPURX) S SCROLOUT="PM"
IF (SCROLEIN["CLINICAL CASE MAN")&(SCROLEIN[SCPURX) S SCROLOUT="CCM"
Q SCROLOUT
TPAIDS(ARRAY,OLDPTPI) ;GET ROLE FROM ID & CHANGE
NEW DATA,ID,SCNEWID,NUM,TYPE,SCROLE,SCNEWROL,SCLOW,SCPTPI
S SCLOW=""
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 DATA=$G(ARRAY(NUM,TYPE,ID))
...; GET ROLE FROM ID & CHANGE
...S SCROLE=$P(ID,"-",4)
...S SCPTPI=$P(ID,"-",1)
...IF SCROLE="PCP" D ;
....S SCNEWROL=$$TPACHK^SCMCHLB("",$P(ID,"-",1),1)
....;IF $L(SCNEWROL) D ;CHANGED IN 532 TO PATTERN MATCH
....I SCNEWROL?1.3A D
.....S SCNEWID=ID
.....S $P(SCNEWID,"-",4)=SCNEWROL
.....S ARRAY(OLDPTPI,SCPTPI,SCNEWID)=DATA
.....K ARRAY(NUM,TYPE,ID)
.....S NUMX=NUM
.....S NUM=OLDPTPI
.....D PTPD^SCMCHLB2(SCPTPI)
.....S NUM=NUMX
.....; XMITARRY="^TMP("PCMM","HL7",546445648)"
.....; K ^TMP("PCMM","HL7",$J,SCPTPI,"EVN")
.....; K ^TMP("PCMM","HL7",$J,SCPTPI,"PID")
.....;K @XMITARRY@(SCPTPI,"EVN",1) comment to stop the missing segments
.....;K @XMITARRY@(SCPTPI,"PID",1) comment to stop the missing segments
Q SCLOW
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCHLB 9785 printed Dec 13, 2024@02:40:24 Page 2
SCMCHLB ;BP/DJB - PCMM HL7 Bld Segment Array ; 3/2/00 2:12pm
+1 ;;5.3;Scheduling;**177,204,210,224,515,532**;AUG 13, 1993;Build 21
+2 ;
BUILD(VARPTR,HL,XMITARRY) ;Build an array of HL7 segments based on EVENT
+1 ;POINTER field in PCMM HL7 EVENT file (#404.48).
+2 ;
+3 ;Input:
+4 ; VARPTR - EVENT POINTER field in PCMM HL7 EVENT file.
+5 ; HL - Array of HL7 variables (pass by reference).
+6 ; Output of call to INIT^HLFNC2().
+7 ; XMITARRY - Array to store HL7 segments (full global ref).
+8 ; Default=^TMP("HLS",$J)
+9 ;Output:
+10 ; XMITARRY(n,segment) array of segments.
+11 ; Examples:
+12 ; ^TMP("PCMM","HL7",$J,2290,"PID")...= PID segment
+13 ; ^TMP("PCMM","HL7",$J,2290,"ZPC",ID)= ZPC segments
+14 ; -1^Error = Unable to build message / bad input
+15 ;
+16 ;Note: The calling program must initialize (i.e. KILL) XMITARRY.
+17 ;
+18 ;Declare variables
+19 NEW RESULT,SCIEN,SCGLB
+20 NEW HLECH,HLEID,HLFS,HLQ
+21 ;
+22 ;Convert VARPTR (ien;global) to SCIEN & SCGLB
+23 SET RESULT=$$CHECK^SCMCHLB1($GET(VARPTR))
+24 ;
+25 IF 'RESULT
QUIT "-1^Did not pass valid variable pointer"
+26 ;
+27 ;Initialize HL7 variables
+28 SET HLECH=HL("ECH")
+29 SET HLFS=HL("FS")
+30 SET HLQ=HL("Q")
+31 ;
+32 ;........................Process a deletion
IF RESULT=2
Begin DoDot:1
+33 ;..Delete - File 404.43
IF SCGLB="SCPT(404.43,"
DO PTP^SCMCHLB2
QUIT
+34 ;..Delete - File 404.52
IF SCGLB="SCTM(404.52,"
DO POS^SCMCHLB2
QUIT
+35 ;..Delete - File 404.53
IF SCGLB="SCTM(404.53,"
DO PRE^SCMCHLB2
QUIT
End DoDot:1
GOTO QUIT
+36 ;..File 404.43
IF SCGLB="SCPT(404.43,"
DO PTP(SCIEN,"")
GOTO QUIT
+37 ;.........File 404.52
IF SCGLB="SCTM(404.52,"
DO POS
GOTO QUIT
+38 ;.........File 404.53
IF SCGLB="SCTM(404.53,"
DO PRE
GOTO QUIT
QUIT QUIT 1
+1 ;
+2 ;==================================================================
+3 ;
PTP(PTPI,SCTPAIN) ;Patient Team Position Assignment (#404.43).
+1 ;Input: PTPI - Patient Team Position Assignment IEN
+2 ;
+3 ;To keep VISTA and NPCD in sync, for this PT TM POS ASSIGN send
+4 ;down a delete for all previous entries, and then send down data
+5 ;for current valid entries.
+6 ;
+7 ;NEW DFN,ERROR,ND,ZDATE,ZPTP
+8 ;djb/bp Added SCSEQ per Patch 210, replace above line with below line
+9 ;NEW DFN,ERROR,ND,SCSEQ,ZDATE,ZPTP
+10 ; ADDED SCLOW SCTPTPA PATCH 515 DLL
+11 NEW DFN,ERROR,ND,SCSEQ,ZDATE,ZPTP,SCLOW,SCTPTPA
+12 ;
+13 ;Get data
+14 SET ND=$GET(^SCPT(404.43,PTPI,0))
+15 ;..Patient
SET DFN=$$DFN^SCMCHLB1(ND)
if 'DFN
QUIT
+16 ;
+17 ;Get only valid entries for this PT TM POS ASSIGN. This call returns
+18 ;provider array for a patient team position assignment.
+19 ;Example: ZPTP(8944,"AP","8944-909-0-AP")=data
+20 ; ZPTP(8944,"PCP","8944-911-157-PCP")=data
+21 KILL ZPTP
+22 ;Set date array
DO SETDATE
+23 SET RESULT=$$PRPTTPC^SCAPMC(PTPI,"ZDATE","ZPTP","ERROR","",1)
+24 ; add check if primary PATCH 515 BEGIN
+25 ; S SCTPTPA=$$TPACHK("",PTPI,SCTPAIN
+26 SET SCTPTPA=$$TPACHK("",PTPI,"")
+27 ; If not primary then call GETOEF to find others
+28 SET SCLOW=PTPI
+29 ;REMOVED IF SCTPTPA=1/532/TEH at first, now it's back in
+30 IF SCTPTPA=1
SET SCLOW=$$GETOEF(PTPI,"","")
+31 ; PATCH 515 END
+32 ;
+33 ;If no valid history don't build any segments
+34 if '$DATA(ZPTP)
QUIT
+35 ;
+36 ;Build EVN & PID segments
+37 DO SEGMENTS^SCMCHLB1(DFN,PTPI)
+38 ;
+39 ;Generate deletes for all ID's starting with this PT TM POS ASSIGN.
+40 ; PATCH 515 - CHG ALWAYS DELETE TO NOT IF TPA
+41 ; OLD CODE = D PTPD^SCMCHLB2(PTPI)
+42 IF SCTPTPA'=1
SET NUM=PTPI
DO PTPD^SCMCHLB2(PTPI)
+43 ;
+44 ;Build data type ZPC segments.
+45 DO ZPC^SCMCHLB1(.ZPTP)
+46 ;alb/rpm;Patch 224 Decrement max msg counter
+47 IF $DATA(SCLIMIT)
SET SCLIMIT=SCLIMIT-1
+48 QUIT
+49 ;
POS ;Position Assign History (#404.52)
+1 ;
+2 ;To keep VISTA and NPCD in sync, for every primary care entry in Pt
+3 ;Tm Pos Assign for this TEAM POSITION, send down all valid entries.
+4 ;
+5 NEW TMPOS,TP
+6 ;
+7 ;Team Position pointer
+8 SET TMPOS=$PIECE($GET(^SCTM(404.52,SCIEN,0)),U,1)
+9 if 'TMPOS
QUIT
+10 ;
+11 ;Get History entries for each PT TM POS ASSIGN
+12 DO POS1(TMPOS)
+13 ;
+14 ;What if this TEAM POSITION is also a preceptor? Find every TEAM
+15 ;POSITION being precepted by this TEAM POSITION and for each, find
+16 ;every PT TM POS ASSIGN and send down all valid History entries.
+17 ;
+18 SET TP=0
+19 FOR
SET TP=$ORDER(^SCTM(404.53,"AD",TMPOS,TP))
if 'TP
QUIT
DO POS1(TP)
+20 QUIT
+21 ;
POS1(TMPOS) ;Find every primary care PT TM POS ASSIGN for this TEAM POSITION
+1 ;and get all valid History entries.
+2 ;Input:
+3 ; TMPOS - TEAM POSITION pointer
+4 ;
+5 if '$GET(TMPOS)
QUIT
+6 NEW IFN,ND,TM,SCTPTPA
+7 SET SCTPTPA=$$TPACHK(TMPOS,"","")
+8 ;
+9 ; ..; PTA CHG 20070518 SD*5.3*515
+10 ; OLD CODE = S TM=0 (WAS MISSING PEOPLE)
+11 SET TM=""
+12 ;
FOR
SET TM=$ORDER(^SCPT(404.43,"APTPA",TMPOS,TM))
if 'TM
QUIT
Begin DoDot:1
+13 SET IFN=0
+14 ;
FOR
SET IFN=$ORDER(^SCPT(404.43,"APTPA",TMPOS,TM,IFN))
if 'IFN
QUIT
Begin DoDot:2
+15 SET ND=$GET(^SCPT(404.43,IFN,0))
+16 ; Q:($P(ND,U,5)'=1) ; Must be Primary Care
+17 ; PTA CHG 20070518 SD*5.3*515
+18 ; Must be Primary Care OR PTA
if (($PIECE(ND,U,5)'=1)&(SCTPTPA=0))
QUIT
+19 ; D PTP(IFN,SCTPTPA) ;..........Bld segments for this PT TM POS ASSIGN
+20 ;..........Bld segments for this PT TM POS ASSIGN
DO PTP(IFN,"")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
PRE ;Preceptor Assign History (#404.53)
+1 ;
+2 ;Get TEAM POSITION pointer of preceptee. Find every primary care
+3 ;PT TM POS ASSIGN for this TEAM POSITION and send down all valid
+4 ;History entries.
+5 ;
+6 NEW TMPOS
+7 ;
+8 ;Preceptee TEAM POSITION pointer
+9 SET TMPOS=$PIECE($GET(^SCTM(404.53,SCIEN,0)),U,1)
+10 if 'TMPOS
QUIT
+11 ;Get History entries for each PT TM POS ASSIGN
DO POS1(TMPOS)
+12 ;
+13 ;Preceptor TEAM POSITION pointer
+14 SET TMPOS=$PIECE($GET(^SCTM(404.53,SCIEN,0)),U,6)
+15 if 'TMPOS
QUIT
+16 ;Get History entries for each PT TM POS ASSIGN
DO POS1(TMPOS)
+17 QUIT
+18 ;
SETDATE ;Set all encompassing date array
+1 SET ZDATE("BEGIN")=2800101
+2 SET ZDATE("END")=9991231
+3 SET ZDATE("INCL")=0
+4 QUIT
TPACHK(SCTP,SCPTPI,SCROLEP) ; CHECK IF TEAM POSITION IS A PTA
+1 ; levyd 20070518 SD*5.3*515
+2 ;Get data FROM 43
+3 NEW ND,SCPC,SCTPD,SCTPX,SCROL,SCTM,SCTPA,TMD,SCTMP,SCTPTA,SCTPA,SCROLX,SCPURX,SCUP,SCLOW,SCROLY
+4 SET SCTPA=0
+5 SET SCPURX="OIF OEF"
+6 SET SCROLX="/TPA/PM/CCM/"
+7 SET SCUP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+8 SET SCLOW="abcdefghijklmnopqrstuvwxyz"
+9 ;
IF $LENGTH(SCPTPI)
Begin DoDot:1
+10 SET ND=$GET(^SCPT(404.43,SCPTPI,0))
+11 ; DEBBIE LEVY PTA CHGS 20070518
+12 ; PRIMARY CARE ROLE CHECK
+13 ;
IF $LENGTH(ND)
SET SCPC=$PIECE(ND,U,5)
Begin DoDot:2
+14 ; TP
IF SCPC'=1
SET SCTP=$PIECE(ND,U,2)
End DoDot:2
End DoDot:1
+15 ; READ TP REC (57)
+16 IF SCTP=""
QUIT SCTPA
+17 SET SCTPD=$GET(^SCTM(404.57,SCTP,0))
+18 ;not primary
SET SCTPX=$PIECE(SCTPD,U,4)
+19 IF SCTPX=1
QUIT SCTPA
+20 SET SCROL=$PIECE(SCTPD,U,3)
+21 SET SCROL=$PIECE(^SD(403.46,SCROL,0),U,1)
+22 IF $GET(SCROLEP)=1
SET SCROL=$$TPACHGRL(SCROL)
QUIT SCROL
+23 IF $GET(SCROLEP)=""
SET SCROL=$$TPACHGRL(SCROL)
+24 SET SCTM=$PIECE(SCTPD,U,2)
+25 SET SCROLY="/"_SCROL_"/"
+26 ; OEF ROLE
SET SCTPA=0
IF SCROLX[SCROLY
SET SCTPA=1
+27 ; READ TEAM FILE (404.51
+28 SET TMD=^SCTM(404.51,SCTM,0)
+29 SET SCTMP=$PIECE(TMD,U,3)
+30 SET SCTMP=^SD(403.47,SCTMP,0)
+31 ; CONVERT STR LOWER CASE TO UPPER CASE
+32 SET SCTMP=$TRANSLATE(SCTMP,SCLOW,SCUP)
+33 SET SCTPTA=0
IF SCTMP[SCPURX
SET SCTPTA=1
+34 IF ((SCTPA=1)&(SCTPTA=1))
SET SCTPA=1
QT QUIT SCTPA
+1 ;
GETOEF(PTPI,EFFDT,ENDDT) ;Find All OIF OEF RELATIONSHIPS FOR THIS TP in TPS array
+1 ; NEW RTN ADDED W PATCH 515 BY DLL
+2 ;Input: TP - Team Position IEN
+3 ; EFFDT = Team Position EFFECTIVE DATE (OPTIONAL)
+4 ; ENDDT = Team Position EXPIRATION DATE (OPTIONAL)
+5 NEW TP,COUNT,TPD,TPX,TPDX,TPXX,TPDXX,SCOLDPAT,SCOLDTM,SCOLDTP,SCLOW,DFNX,DFNY
+6 SET SCLOW=PTPI
+7 IF ENDDT=""
SET ENDDT=9991231
+8 KILL SCTPS,SCPCP
+9 ; save original trigger TP, person and team
+10 SET SCOLD43I=PTPI
+11 ;Get data
+12 SET ND=$GET(^SCPT(404.43,PTPI,0))
+13 SET DFNY=$PIECE(ND,U,1)
+14 SET DFNX=$GET(^SCPT(404.42,DFNY,0))
+15 SET SCOLDTP=$PIECE(ND,U,2)
+16 SET SCOLDPAT=$PIECE(DFNX,U,1)
+17 SET SCOLDTM=$PIECE(DFNX,U,3)
+18 ; read thru the patient assignments for this person in 42 ^SCPT(404.42,"B",3994,6930)
+19 SET TPX=""
+20 SET COUNT=0
+21 FOR
SET TPX=$ORDER(^SCPT(404.42,"B",SCOLDPAT,TPX))
if 'TPX
QUIT
Begin DoDot:1
+22 SET TPDX=$GET(^SCPT(404.42,TPX,0))
+23 ;MUST be SAME TEAM
if $PIECE(TPDX,U,3)'=SCOLDTM
QUIT
+24 ; red thru the the assignments for this patient ass in 43 ^SCPT(404.43,"B",6930
+25 SET TPXX=""
+26 FOR
SET TPXX=$ORDER(^SCPT(404.43,"B",TPX,TPXX))
if 'TPXX
QUIT
Begin DoDot:2
+27 SET TPDXX=$GET(^SCPT(404.43,TPXX,0))
+28 SET TP=$PIECE(TPDXX,U,2)
+29 ; TP NOT THERE ALREADY THEN ADD IT TO SCTPS
IF $GET(SCPCP(TP))'=1
Begin DoDot:3
+30 SET COUNT=COUNT+1
+31 SET SCTPS(COUNT)=TP
+32 SET SCPCP(TP)=1
+33 IF TP'=SCOLDTP
Begin DoDot:4
+34 SET RESULT=$$PRPTTPC^SCAPMC(TPXX,"ZDATE","ZPTP","ERROR","",1)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 SET SCLOW=$$TPAIDS(.ZPTP,.PTPI)
+36 QUIT SCLOW
TPACHGRL(SCROLEIN) ;ROLE ABBREVIATION
+1 NEW SCUP,SCLOW,SCPURX
+2 SET SCPURX="OIF OEF"
+3 SET SCROLOUT=""
+4 if $LENGTH($GET(SCROLEIN))=0
QUIT
+5 SET SCUP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+6 SET SCLOW="abcdefghijklmnopqrstuvwxyz"
+7 ; CONVERT STR LOWer case TO UPper case
+8 SET SCROLEIN=$TRANSLATE(SCROLEIN,SCLOW,SCUP)
+9 IF (SCROLEIN["TRANSITION PATIENT ADV")&(SCROLEIN[SCPURX)
SET SCROLOUT="TPA"
+10 IF (SCROLEIN["PROGRAM MANA")&(SCROLEIN[SCPURX)
SET SCROLOUT="PM"
+11 IF (SCROLEIN["CLINICAL CASE MAN")&(SCROLEIN[SCPURX)
SET SCROLOUT="CCM"
+12 QUIT SCROLOUT
TPAIDS(ARRAY,OLDPTPI) ;GET ROLE FROM ID & CHANGE
+1 NEW DATA,ID,SCNEWID,NUM,TYPE,SCROLE,SCNEWROL,SCLOW,SCPTPI
+2 SET SCLOW=""
+3 SET NUM=0
+4 ;
FOR
SET NUM=$ORDER(ARRAY(NUM))
if 'NUM
QUIT
Begin DoDot:1
+5 SET TYPE=""
+6 ;
FOR
SET TYPE=$ORDER(ARRAY(NUM,TYPE))
if TYPE=""
QUIT
Begin DoDot:2
+7 SET ID=""
+8 ;
FOR
SET ID=$ORDER(ARRAY(NUM,TYPE,ID))
if ID=""
QUIT
Begin DoDot:3
+9 SET DATA=$GET(ARRAY(NUM,TYPE,ID))
+10 ; GET ROLE FROM ID & CHANGE
+11 SET SCROLE=$PIECE(ID,"-",4)
+12 SET SCPTPI=$PIECE(ID,"-",1)
+13 ;
IF SCROLE="PCP"
Begin DoDot:4
+14 SET SCNEWROL=$$TPACHK^SCMCHLB("",$PIECE(ID,"-",1),1)
+15 ;IF $L(SCNEWROL) D ;CHANGED IN 532 TO PATTERN MATCH
+16 IF SCNEWROL?1.3A
Begin DoDot:5
+17 SET SCNEWID=ID
+18 SET $PIECE(SCNEWID,"-",4)=SCNEWROL
+19 SET ARRAY(OLDPTPI,SCPTPI,SCNEWID)=DATA
+20 KILL ARRAY(NUM,TYPE,ID)
+21 SET NUMX=NUM
+22 SET NUM=OLDPTPI
+23 DO PTPD^SCMCHLB2(SCPTPI)
+24 SET NUM=NUMX
+25 ; XMITARRY="^TMP("PCMM","HL7",546445648)"
+26 ; K ^TMP("PCMM","HL7",$J,SCPTPI,"EVN")
+27 ; K ^TMP("PCMM","HL7",$J,SCPTPI,"PID")
+28 ;K @XMITARRY@(SCPTPI,"EVN",1) comment to stop the missing segments
+29 ;K @XMITARRY@(SCPTPI,"PID",1) comment to stop the missing segments
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+30 QUIT SCLOW
