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

SCMCHLB.m

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