- ECXSCXN1 ;ALB/JAP Clinic Extract No Shows; 8/28/02 1:11pm ;1/25/19 10:50
- ;;3.0;DSS EXTRACTS;**71,105,127,132,136,144,166,170,174,184**;Dec 22, 1997;Build 124
- NOSHOW(ECXSD,ECXED) ;get noshows from file #44
- ; ECXSD = start date, ECXED = end date
- N ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV,ECXEDIS,CNT,ECXARR,ECXSDSC,ECXEDSC,ECXASIH ;136,170
- N ECXECL,ECXESC,ECXCLST ;144 Call to INTPAT^ECXSCX2 sets variables to null. Call to PAT1^ECXSCX2 will set camp lejeune status when available. Encounter values remain null as appt is a no-show
- N ECXSCST ;174 Call to PAT1^ECXSCX2 will set the service connected status
- N ECXNOCNT ;174 Clinic non-count flag
- S CLIN=0
- F S CLIN=$O(^TMP($J,"ECXCL",CLIN)) Q:'CLIN!($G(QFLG)) D ;136
- .Q:$P($G(^TMP($J,"ECXCL",CLIN)),U,3)'="C"
- .S (P1,P2,P3,P4)="" ;166 add P4
- .D FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV,.P4) ;166 add P4 parameter
- .Q:TOSEND=6
- .;find appts in date range
- .S ECXSDSC=ECXSD+.1,ECXEDSC=$P(ECXED,".") ;136 get dates back into correct fileman format
- .S (ALEN,NOSHOW)="" ;136
- .K ^TMP($J,"SDAMA301") ;136
- .S ECXARR(1)=ECXSDSC_";"_ECXEDSC,ECXARR(2)=CLIN,ECXARR(3)="NS;NSR",ECXARR("FLDS")="5;7;10;12;18" ;136
- .S CNT=$$SDAPI^SDAMA301(.ECXARR) ;136
- .Q:CNT=0 I CNT=-1 D ERR^ECXUTL1 S QFLG=1 Q ;136 Stop if no data (CNT=0) and send error message if scheduling system down (CNT=-1)
- .S JJ=0 F S JJ=$O(^TMP($J,"SDAMA301",CLIN,JJ)) Q:'+JJ S JDATE="" F S JDATE=$O(^TMP($J,"SDAMA301",CLIN,JJ,JDATE)) Q:'+JDATE D ;136
- ..S ECXDATE=JDATE,ECXTI=$$ECXTIME^ECXUTL(JDATE) ;136,166
- ..S ECXDFN=JJ ;136
- ..S ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN) ;added in patch 127
- ..S NODE=$G(^TMP($J,"SDAMA301",CLIN,JJ,JDATE)),MDIV=$P($G(^SC(CLIN,0)),U,15) ;136
- ..Q:NODE="" ;136
- ..S ECXNOCNT=$P($G(^TMP($J,"ECXCL",CLIN)),U,5) ;174 Get non-count status
- ..S ECXSHAD=$$GETSHAD ;added in patch 127, finds shad status for appt
- ..S ECXOBI=$S($P(NODE,U,7)="Y":"O",1:"") ;136
- ..S NOSHOW="N" ;136 only no-show entries are returned from the SDAMA301 call
- ..D INTPAT^ECXSCX2 S ECXERR=0
- ..D PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR) Q:ECXERR
- ..I ECXLOGIC>2022 S ECXNMPI=ECXMPI ;184
- ..S ALEN=$$RJ^XLFSTR($P(NODE,U,5),3,0) ;136
- ..D PAT2^ECXSCX2(ECXDFN,ECXDATE)
- ..S ECXPVST=+$P(NODE,U,18),ECXATYP=+$P(NODE,U,10) ;136 Get POV & appt type
- ..S:+ALEN=0 ALEN=$P($G(^TMP($J,"ECXCL",CLIN)),U,2)
- ..S ECXCLIN=CLIN,ECXSTOP=P1
- ..S ECXEDIS=$$EDIS^ECXUTL1(ECXDFN,ECXDATE,"N",,ECXSTOP) ;136
- ..I ECXLOGIC<2019 S:ECXCPT1="" ECXCPT1="9919901" ;170 tjl - Retain value for prior years
- ..I ECXLOGIC>2018 S:ECXCPT1="" ECXCQM1="9919901" ;170 tjl - Set new variable value
- ..S ECXCBOC=$S(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")
- ..S (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN,ECXPRX12)="" ;184 - Added ECXPRX12
- ..F I=1:1:7 S (@("ECSP"_I),@("ECSPPC"_I),@("ECSPNPI"_I))="" ;144 2 new prov groups
- ..I TOSEND'=3 D
- ...S ECXKEY=P1_P2_ALEN_P3_NOSHOW_P4,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) ;166
- ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
- ..I TOSEND=3 D
- ...S ECXKEY=P1_"000"_ALEN_P3_NOSHOW_P4,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) ;166
- ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
- ..I TOSEND=3 D
- ...S ECXKEY=P2_"000"_ALEN_P3_NOSHOW_P4,ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY) ;166
- ...S ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,) D:ECXENC'="" FILE^ECXSCXN
- ..;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows
- Q
- ;GETSHAD section added with patch 127
- GETSHAD() ;Function returns shad value
- N DIC,LOCARR,DA,DR,SHAD,ECXERR,ECXVIST
- S SHAD=""
- I '+$P($G(NODE),U,12) Q SHAD ;136 Quit if no outpatient encounter pointer
- S DIC=409.68,DA=$P(NODE,U,12),DR=.05,DIQ(0)="I",DIQ="LOCARR" ;136
- D EN^DIQ1
- I $G(LOCARR(409.68,DA,.05,"I")) D
- .S ECXERR=0
- .D VISIT^ECXSCX1(ECXDFN,LOCARR(409.68,DA,.05,"I"),.ECXVIST,.ECXERR)
- .I 'ECXERR S SHAD=ECXVIST("SHAD")
- Q SHAD
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXSCXN1 4134 printed Jan 18, 2025@02:55:10 Page 2
- ECXSCXN1 ;ALB/JAP Clinic Extract No Shows; 8/28/02 1:11pm ;1/25/19 10:50
- +1 ;;3.0;DSS EXTRACTS;**71,105,127,132,136,144,166,170,174,184**;Dec 22, 1997;Build 124
- NOSHOW(ECXSD,ECXED) ;get noshows from file #44
- +1 ; ECXSD = start date, ECXED = end date
- +2 ;136,170
- NEW ALEN,CLIN,JDATE,JJ,NODE,NOSHOW,PP,STAT,MDIV,ECXEDIS,CNT,ECXARR,ECXSDSC,ECXEDSC,ECXASIH
- +3 ;144 Call to INTPAT^ECXSCX2 sets variables to null. Call to PAT1^ECXSCX2 will set camp lejeune status when available. Encounter values remain null as appt is a no-show
- NEW ECXECL,ECXESC,ECXCLST
- +4 ;174 Call to PAT1^ECXSCX2 will set the service connected status
- NEW ECXSCST
- +5 ;174 Clinic non-count flag
- NEW ECXNOCNT
- +6 SET CLIN=0
- +7 ;136
- FOR
- SET CLIN=$ORDER(^TMP($JOB,"ECXCL",CLIN))
- if 'CLIN!($GET(QFLG))
- QUIT
- Begin DoDot:1
- +8 if $PIECE($GET(^TMP($JOB,"ECXCL",CLIN)),U,3)'="C"
- QUIT
- +9 ;166 add P4
- SET (P1,P2,P3,P4)=""
- +10 ;166 add P4 parameter
- DO FEEDER^ECXSCX1(CLIN,ECXSD,.P1,.P2,.P3,.TOSEND,.ECXDIV,.P4)
- +11 if TOSEND=6
- QUIT
- +12 ;find appts in date range
- +13 ;136 get dates back into correct fileman format
- SET ECXSDSC=ECXSD+.1
- SET ECXEDSC=$PIECE(ECXED,".")
- +14 ;136
- SET (ALEN,NOSHOW)=""
- +15 ;136
- KILL ^TMP($JOB,"SDAMA301")
- +16 ;136
- SET ECXARR(1)=ECXSDSC_";"_ECXEDSC
- SET ECXARR(2)=CLIN
- SET ECXARR(3)="NS;NSR"
- SET ECXARR("FLDS")="5;7;10;12;18"
- +17 ;136
- SET CNT=$$SDAPI^SDAMA301(.ECXARR)
- +18 ;136 Stop if no data (CNT=0) and send error message if scheduling system down (CNT=-1)
- if CNT=0
- QUIT
- IF CNT=-1
- DO ERR^ECXUTL1
- SET QFLG=1
- QUIT
- +19 ;136
- SET JJ=0
- FOR
- SET JJ=$ORDER(^TMP($JOB,"SDAMA301",CLIN,JJ))
- if '+JJ
- QUIT
- SET JDATE=""
- FOR
- SET JDATE=$ORDER(^TMP($JOB,"SDAMA301",CLIN,JJ,JDATE))
- if '+JDATE
- QUIT
- Begin DoDot:2
- +20 ;136,166
- SET ECXDATE=JDATE
- SET ECXTI=$$ECXTIME^ECXUTL(JDATE)
- +21 ;136
- SET ECXDFN=JJ
- +22 ;added in patch 127
- SET ECXPATCAT=$$PATCAT^ECXUTL(ECXDFN)
- +23 ;136
- SET NODE=$GET(^TMP($JOB,"SDAMA301",CLIN,JJ,JDATE))
- SET MDIV=$PIECE($GET(^SC(CLIN,0)),U,15)
- +24 ;136
- if NODE=""
- QUIT
- +25 ;174 Get non-count status
- SET ECXNOCNT=$PIECE($GET(^TMP($JOB,"ECXCL",CLIN)),U,5)
- +26 ;added in patch 127, finds shad status for appt
- SET ECXSHAD=$$GETSHAD
- +27 ;136
- SET ECXOBI=$SELECT($PIECE(NODE,U,7)="Y":"O",1:"")
- +28 ;136 only no-show entries are returned from the SDAMA301 call
- SET NOSHOW="N"
- +29 DO INTPAT^ECXSCX2
- SET ECXERR=0
- +30 DO PAT1^ECXSCX2(ECXDFN,ECXDATE,.ECXERR)
- if ECXERR
- QUIT
- +31 ;184
- IF ECXLOGIC>2022
- SET ECXNMPI=ECXMPI
- +32 ;136
- SET ALEN=$$RJ^XLFSTR($PIECE(NODE,U,5),3,0)
- +33 DO PAT2^ECXSCX2(ECXDFN,ECXDATE)
- +34 ;136 Get POV & appt type
- SET ECXPVST=+$PIECE(NODE,U,18)
- SET ECXATYP=+$PIECE(NODE,U,10)
- +35 if +ALEN=0
- SET ALEN=$PIECE($GET(^TMP($JOB,"ECXCL",CLIN)),U,2)
- +36 SET ECXCLIN=CLIN
- SET ECXSTOP=P1
- +37 ;136
- SET ECXEDIS=$$EDIS^ECXUTL1(ECXDFN,ECXDATE,"N",,ECXSTOP)
- +38 ;170 tjl - Retain value for prior years
- IF ECXLOGIC<2019
- if ECXCPT1=""
- SET ECXCPT1="9919901"
- +39 ;170 tjl - Set new variable value
- IF ECXLOGIC>2018
- if ECXCPT1=""
- SET ECXCQM1="9919901"
- +40 SET ECXCBOC=$SELECT(MDIV'="":$$CBOC^ECXSCX2(.MDIV),1:"")
- +41 ;184 - Added ECXPRX12
- SET (ECXDSSD,ECXENEL,ECXIR,ECXAO,ECXMIL,ECXPROV,ECXPROVP,ECXPROVN,ECXPRX12)=""
- +42 ;144 2 new prov groups
- FOR I=1:1:7
- SET (@("ECSP"_I),@("ECSPPC"_I),@("ECSPNPI"_I))=""
- +43 IF TOSEND'=3
- Begin DoDot:3
- +44 ;166
- SET ECXKEY=P1_P2_ALEN_P3_NOSHOW_P4
- SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
- +45 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,)
- if ECXENC'=""
- DO FILE^ECXSCXN
- End DoDot:3
- +46 IF TOSEND=3
- Begin DoDot:3
- +47 ;166
- SET ECXKEY=P1_"000"_ALEN_P3_NOSHOW_P4
- SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
- +48 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,)
- if ECXENC'=""
- DO FILE^ECXSCXN
- End DoDot:3
- +49 IF TOSEND=3
- Begin DoDot:3
- +50 ;166
- SET ECXKEY=P2_"000"_ALEN_P3_NOSHOW_P4
- SET ECXOBS=$$OBSPAT^ECXUTL4(ECXA,ECXTS,ECXKEY)
- +51 SET ECXENC=$$ENCNUM^ECXUTL4(ECXA,ECXSSN,ECXADMDT,ECXDATE,ECXTS,ECXOBS,ECHEAD,ECXKEY,)
- if ECXENC'=""
- DO FILE^ECXSCXN
- End DoDot:3
- +52 ;create a record for noshow appended ekg. The code was removed for CTX-0604-70970 CLI Extract Problem EXPANDED to NoShows
- End DoDot:2
- End DoDot:1
- +53 QUIT
- +54 ;GETSHAD section added with patch 127
- GETSHAD() ;Function returns shad value
- +1 NEW DIC,LOCARR,DA,DR,SHAD,ECXERR,ECXVIST
- +2 SET SHAD=""
- +3 ;136 Quit if no outpatient encounter pointer
- IF '+$PIECE($GET(NODE),U,12)
- QUIT SHAD
- +4 ;136
- SET DIC=409.68
- SET DA=$PIECE(NODE,U,12)
- SET DR=.05
- SET DIQ(0)="I"
- SET DIQ="LOCARR"
- +5 DO EN^DIQ1
- +6 IF $GET(LOCARR(409.68,DA,.05,"I"))
- Begin DoDot:1
- +7 SET ECXERR=0
- +8 DO VISIT^ECXSCX1(ECXDFN,LOCARR(409.68,DA,.05,"I"),.ECXVIST,.ECXERR)
- +9 IF 'ECXERR
- SET SHAD=ECXVIST("SHAD")
- End DoDot:1
- +10 QUIT SHAD