- 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 Jan 18, 2025@03:41:33 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