ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ;5/9/17 12:31
;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105,112,120,126,132,136,142,144,149,154,161,166,184**;Dec 22, 1997;Build 124
EN ;entry point from option
;load entries
N DIR,X,Y,DIRUT,DTOUT,DUOUT,ZTSK ;144,161
W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES"
W !,"file (#728.44).",! ;144
I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
;W !!,"It also compares file #728.44 to the HOSPITAL LOCATION file (#44) to see" ;144
;W !,"if there are any differences since the last time the file was reviewed." ;144
;W !!,"Any differences or new entries will cause an UNREVIEWED CLINICS report" ;144
;W !,"to automatically print.",! ;144
;D SELECT^ECXSCLD ;144
;144 does user hold key?
I '$$KCHK^XUSRB("ECXMGR",$G(DUZ)) D G ENDX ;144
.W !!,?5,"You do not have approved access to this option.",!,"Exiting...",!! ;144
.D PAUSE ;144
W !,"The CREATE option last ran on ",$S($D(^ECX(728.44,"C")):$$FMTE^XLFDT($O(^ECX(728.44,"C"," "),-1),2),1:"- No date on file"),".",! ;144
S ZTSK=$O(^XTMP("ECX CREATE",0)) I ZTSK D ;161 Added section for future tasking of create option
.D ISQED^%ZTLOAD I '$G(ZTSK(0)) K ^XTMP("ECX CREATE") Q ;see if task is still queued. Delete XTMP if task no longer exists
.W !,"A future CREATE option is scheduled to run on ",$$HTE^XLFDT($G(ZTSK("D"))),".",!,"It was scheduled by ",$$GET1^DIQ(200,$G(ZTSK("DUZ")),.01),".",!
.Q
S DIR(0)="SA^N:NOW;Q:QUEUE",DIR("A")="Run the CREATE option (N)ow or (Q)ueue for a future date/time: " ;161
S DIR("?",1)="Enter N to run immediately or Q to run in the background at a future date/time.",DIR("?")="Enter ^ to skip running the CREATE option." ;161
D ^DIR Q:$G(DIRUT) ;161
I Y="Q" S ZTSK=$$NODEV^XUTMDEVQ("START^ECXSCLD","DSS CREATE UTILITY",,,1) S:$G(ZTSK)>0 ^XTMP("ECX CREATE",0)=$$FMADD^XLFDT(DT,365)_"^"_DT_"^"_"Create option",^XTMP("ECX CREATE",ZTSK)="" Q ;161 Get future date/time to run create option
W !,"Running CREATE..." ;144
D START ;144
W !!,"The CREATE option has completed on ",$$FMTE^XLFDT($$NOW^XLFDT),".",! ;144
S DIR(0)="Y",DIR("A")="Proceed to DSS Clinic and Stop Code Print menu",DIR("B")="NO" D ^DIR ;144
D:Y PRINT ;144
Q
START ; entry point
N ZTREQ
S EC=0 F S EC=$O(^SC(EC)) Q:'EC D FIX(EC)
K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK
S ZTREQ="@"
I $G(ZTQUEUED) K ^XTMP("ECX CREATE") ;161 If running in the background, kill of XTMP node
Q
;
FIX(EC) ;
; synchronize files #44 and #728.44.
N DIE,DA,DR ;144
; differences are placed in ^XTMP("ECX UNREVIEWED CLINICS")
S EC=$G(EC)
I '$D(^SC(EC,0)) Q
N ECD,DAT
S ECD=^SC(EC,0),DAT=$G(^SC(EC,"I"))
I $P(ECD,U,3)'="C" I '$D(^ECX(728.44,EC,0)) Q ;144 Allow updates if entry already exists in 728.44 even if it's no longer a clinic
; get stop codes and default style for feeder key
; 6 if non-count clinic, otherwise 5 - Patch 166, tjl
K ECD2,ECS2,ECDNEW,ECDDIF,ECSCSIGN I $D(^ECX(728.44,EC,0)) S (ECD2,ECDDIF)=^(0),ECSCSIGN=""
I $D(ECD2) F ECS=2,3,4,5 D
.S (ECS2(ECS),X)=$P(ECD2,U,ECS)
.K DIC,Y S DIC=40.7,DIC(0)="MXZ" D ^DIC
.I +$G(Y)>0 S $P(ECS2(ECS),U,2)=$P(^DIC(40.7,+Y,0),U,3)
S ID=+DAT,RD=$P(DAT,U,2)
;change in clinic inactivation for existing entry
I $D(ECD2) D
.;don't include already old inactivated clinics in report
.I ID,ID'>DT I ('RD)!(RD>DT) I $P(ECD2,U,10)'=ID D
..S $P(ECD2,U,7)="",$P(ECD2,U,10)=ID,ECSCSIGN="*"
.I ID,RD,(RD'>DT) I $P(ECD2,U,10) D
..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="r"
.I ID,(ID>DT) I $P(ECD2,U,10) D
..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="!"
.I 'ID,$P(ECD2,U,10) D
..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="!"
.S ECDDIF=ECD2
;setup for stops
F ECS=7,18 S ECP=+$P(ECD,U,ECS),ECS(ECS)=$P($G(^DIC(40.7,ECP,0)),U,2)_U_$P($G(^DIC(40.7,ECP,0)),U,3)
S ECDF=5 S:$P(ECD,U,17)="Y" ECDF=6 S:$G(^SC(EC,"OOS")) ECDF=5 ;161,166 tjl - Default for "OOS" clinics should be 5, not 6
S ECDB=EC_U_$S(+ECS(7):+ECS(7),1:"")_U_$S(+ECS(18):+ECS(18),1:"")_U_$S(+ECS(7):+ECS(7),1:"")_U_$S(+ECS(18):+ECS(18),1:"") ;154 added DSS SC CSC
;new entry
I '$D(ECD2) D
.S $P(^ECX(728.44,EC,0),U,1,5)=ECDB ;154
.;S $P(^ECX(728.44,EC,0),U,1,5)=ECDB_U_$S(+ECS(7):+ECS(7),1:"")_U_$S(+ECS(18):+ECS(18),1:"")
.S $P(^(0),U,6)=ECDF,$P(^(0),U,12)=$P(ECD,U,17)
.S ECDNEW=^ECX(728.44,EC,0)
;changes to existing entry
I $D(ECD2) D
.S $P(ECD2,U,1,5)=ECDB,$P(ECDDIF,U,1,3)=ECDB ;154 ADDED DSS SC CSC
.;differs in stop code
.I +ECS(7)'=+ECS2(2) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,2)_"!",$P(ECDDIF,U,2)=X ;W !," SC ",?10,X,?20,ECS(7),?40,ECS2(2)
.;154 added DSS STOP CODE
.I +ECS(7)'=+ECS2(4) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,4)_"!",$P(ECDDIF,U,4)=X ;W !,"DSS SC ",?10,X,?20,ECS(7),?40,ECS2(4)
.;differs in credit stop code
.I +ECS(18)'=+ECS2(3) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,3)_"!",$P(ECDDIF,U,3)=X
.;154 added DSS CREDIT STOP CODE
.I +ECS(18)'=+ECS2(5) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,5)_"!",$P(ECDDIF,U,5)=X ; W !,"DSS CSC",!
.;change in non-count
.I $P(ECD2,U,12)'=$P(ECD,U,17) S X=$P(ECD,U,17)_"!",$P(ECDDIF,U,12)=X,$P(ECD2,U,12)=$P(ECD,U,17),$P(ECD2,U,7)=""
.;reset entry
.S ^ECX(728.44,EC,0)=ECD2
;set tmp node
S ECSC=$P(ECD,U) S:$L(ECSC)>27 ECSC=$E(ECSC,1,27)
I $D(ECD2),$P(ECD2,U,7)="" D
.I $D(^XTMP("ECX UNREVIEWED CLINICS",ECSC)) D UPDATE(ECSC,ECDDIF,ECSCSIGN)
.I '$D(^XTMP("ECX UNREVIEWED CLINICS",ECSC)) S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=ECSCSIGN_U_$P(ECDDIF,U,2,200),^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT()
I $D(ECDNEW) S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=""_U_$P(ECDNEW,U,2,200),^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT()
S DIE=728.44,DA=EC,DR="12///TODAY" D ^DIE ;144 Set create date to today's date
Q
;
UPDATE(ECSC,ECDDIF,ECSCSIGN) ;update ^xtmp node with today's changes
N ECXOLD,J,L1,L2,X,X1,X2
S ECXOLD=^XTMP("ECX UNREVIEWED CLINICS",ECSC)
F J=2,3,4,5 S X1=+$P(ECXOLD,U,J),X2=+$P(ECDDIF,U,J) I X2=X1,$P(ECDDIF,U,J)'=$P(ECXOLD,U,J) D
.S L1=$L($P(ECXOLD,U,J)),L2=$L($P(ECDDIF,U,J))
.I L1>L2 S $P(ECDDIF,U,J)=$P(ECXOLD,U,J)
S X1=$E($P(ECXOLD,U,12),1),X2=$E($P(ECDDIF,U,12),1) I X2=X1 S $P(ECDDIF,U,12)=$P(ECXOLD,U,12)
S X1=$P(ECXOLD,U),X=X1_U_$P(ECDDIF,U,2,200)
I ECSCSIGN'="",ECSCSIGN'=X1 S X=ECSCSIGN_U_$P(ECDDIF,U,2,200)
S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=X
Q
;
SELECT ;select IO device to 'gather clinic stop codes' and print 'unreviewd clinics' report;
;for menu option 'Create DSS Clinic Stop Code File' or 'Clinics and DSS Stop Codes Print'
N DIR,ECALL,IOP,POP,XX,ZTIO,ZTRTN,ZTDESC,ZTSK,ZTSAVE
;does user hold key?
I '$$KCHK^XUSRB("ECXMGR",$G(DUZ)) D G ENDX
.W !!,?5,"You do not have approved access to this option.",!,"Exiting...",!!
.D PAUSE
W !,"Please select a print device for the 'Unreviewed Clinics' report."
W !,"**Please note: If printing in foreground, synching files may cause screen delay."
W ! S %ZIS="Q" D ^%ZIS
I POP Q
;queue the report
I $D(IO("Q")) D Q
. K ZTSAVE S ZTDESC="Gather Clinic Stop Codes for DSS",ZTRTN="START^ECXSCLD"
. D ^%ZTLOAD
. I $G(ZTSK) W !,"Queued as Task #: "_ZTSK D ENDX D PAUSE
W !!,">> Synchronizing Stop Codes file (#728.44) with the Hospital"
W !," Location file (#44)...",!
D START
D ^%ZISC,HOME^%ZIS K IO("Q")
Q
;
PRINT ; print worksheet for updates
N OUT,DIR,ECALL,ECXMCA,ECXCLX
I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
W !!,"This option produces a worksheet of (A) All Clinics, (C) Active, (D) Duplicate, (I) Inactive, "
W !,"or only the (U) Unreviewed Clinics that are awaiting approval."
W !!,"Clinics that were defined as ""inactive"" by MAS/HAS the last time the"
W !,"option ""Create DSS Clinic Stop Code File"" was run will be indicated with",!,"an ""*""."
W !!,"Choose (X) for exporting the CLINICS AND STOP CODES FILE to a text file for"
W !,"spreadsheet use.",!
W !,"**REMINDER - The CREATE option last ran on ",$S($D(^ECX(728.44,"C")):$$FMTE^XLFDT($O(^ECX(728.44,"C"," "),-1),2),1:"- No date on file"),"." ;144
W !,"If the most recent clinic changes from the HOSPITAL LOCATION file #44",!,"are desired, run the CREATE option before running a report.**",! ;144
S DIR(0)="S^A:ALL CLINICS;C:ALL ACTIVE CLINICS;D:DUPLICATE CLINICS;I:ALL INACTIVE CLINICS;U:UNREVIEWED CLINICS;X:EXPORT TO TEXT FILE FOR SPREADSHEET USE",DIR("A")="Enter ""A"", ""C"", ""D"", ""I"", ""U"", or ""X""" ;149
S DIR("?",1)="Enter: ""C"" to print a worksheet of all active DSS Clinic Stops,"
S DIR("?",2)="Enter: ""I"" to print a worksheet of all inactive DSS Clinic Stops,"
S DIR("?",3)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,"
S DIR("?",4)="Enter: ""U"" to print only the Clinic Stops that have not been approved."
S DIR("?",5)="Enter: ""D"" to print the Duplicate Clinics found." ;149
S DIR("?")="Enter: ""X"" to export CLINICS AND STOP CODES FILE to a text file."
D ^DIR K DIR G ENDX:$D(DIRUT) S ECALL=$E(Y)
I ECALL="X" D EXPORT^ECXSCLD1 Q
I ECALL'="D" W !!,"**REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY**",! ;161
S %ZIS="Q" D ^%ZIS Q:POP
I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q
SPRINT ; queued entry to print work sheet
N DC,ECSDC,DIV1,DIV2,APPL,APPL1,APPL2,STOPC,CREDSC,NATC,DUPIEN,FIEN,ECSC,ECSCI,ECSC2 ;149
N ECSTA6A ;184
U IO
S QFLG=0,$P(LN,"-",$S(ECALL="D":80,1:132))="",PG=0 ;161
S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0")
K ^TMP("EC",$J) ;144
I ECALL'="D" D
.F J=0:0 S J=$O(^ECX(728.44,J)) Q:'J I $D(^ECX(728.44,J,0)) S ECSD=^ECX(728.44,J,0) D
..I $P($G(^SC(J,0)),U,3)'="C" Q ;144 Don't include entries that aren't clinic types
..I ECALL="A" I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
..I (ECALL="I"),($P(ECSD,U,10)) I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
..I ((ECALL="C")&($P(ECSD,U,10)=""))!((ECALL="C")&($P(ECSD,U,10)>DT)) I $D(^SC(J,0)) S ECSC=$P(^(0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
..I ECALL="U" I $P(ECSD,U,7)="" I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200) ;144
.D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! Q ;144
.I ECALL'="D" D ;149
..F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC="" S ECD=^TMP("EC",$J,ECSC) D SHOWEM Q:QFLG ;149
I ECALL="D" D
.S FIRST=1
.F DC=0:0 S DC=$O(^ECX(728.44,DC)) Q:'DC I $D(^ECX(728.44,DC,0)) S ECSDC=^ECX(728.44,DC,0) D
..I $P($G(^SC(DC,0)),U,3)'="C"!($P(^ECX(728.44,DC,0),U,10)'="") Q ;149 Don't include non clinic types or inactive ones
..I $D(^SC(DC,0)) D
...S STOPC=$P(ECSDC,U,2),CREDSC=$P(ECSDC,U,3),NATC=$P(ECSDC,U,8) ;154 CVW
...S DIV=$$GET1^DIQ(44,$P(ECSDC,U),3.5,"I"),APPL=$$GET1^DIQ(44,$P(ECSDC,U),1912,"I"),ECXMCA=$$GET1^DIQ(728.442,$P(ECSDC,U,14),.01) ;166
...S ECSTA6A=$$GET1^DIQ(4,$P(ECSDC,U,15),99,"E") ;184
...I 'FIRST D
....I $D(^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA)) D ;166
.....S ^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,0)="1" ;166
...S ECSC=$P(^SC(DC,0),U),^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,DC,ECSC)=ECSC_U_DC_U_STOPC_U_CREDSC_U_$$GET1^DIQ(728.441,NATC,.01)_U_ECXMCA_U_APPL_U_DIV_U_ECSTA6A ;166 ,184 - added STA6A
..I FIRST D
...S ECSC=$P(^SC(DC,0),U),^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,DC,ECSC)=ECSC_U_DC_U_STOPC_U_CREDSC_U_$$GET1^DIQ(728.441,NATC,.01)_U_ECXMCA_U_APPL_U_DIV_U_ECSTA6A,FIRST=0 ;166,184 - Added STA6A
.D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! Q ;144
I ECALL="D" D
.S KEY="" F S KEY=$O(^TMP("EC",$J,KEY)) Q:'+KEY I $G(^TMP("EC",$J,KEY,0)) Q:QFLG D
..S IEN=0 F S IEN=$O(^TMP("EC",$J,KEY,IEN)) Q:'+IEN!(QFLG) S NAME="" F S NAME=$O(^TMP("EC",$J,KEY,IEN,NAME)) Q:NAME=""!(QFLG) D
...I $Y+6>IOSL D HEAD Q:QFLG
...S ECXCLX=^TMP("EC",$J,KEY,IEN,NAME) ;166
...W !,$P(ECXCLX,U) ;161,166
...W ?32,$P(ECXCLX,U,2),?44,$P(ECXCLX,U,3),?50,$P(ECXCLX,U,4),?55,$P(ECXCLX,U,5),?61,$P(ECXCLX,U,6) ;161,166
...W ?67,$P(^TMP("EC",$J,KEY,IEN,NAME),U,7),?76,$P(^TMP("EC",$J,KEY,IEN,NAME),U,8) ;161,166
...W ?82,$P(^TMP("EC",$J,KEY,IEN,NAME),U,9) ;184
..Q:QFLG W !
..I $Y+6>IOSL D HEAD Q:QFLG
K ^TMP("EC",$J) ;144
I $E(IOST)="C",'QFLG D SS^ECXSCLD1 ;161
D ENDX ;161
W:$Y @IOF D ^%ZISC S ZTREQ="@"
Q
HEAD ; header for worksheet 149 moved to ECXSCLD1 due to size
D HEAD^ECXSCLD1
Q
;
SHOWEM ; list clinics for worksheet 149 moved to ECXSCLD1 due to size
D SHOWEM^ECXSCLD1
Q
EDIT ; put in DSS stopcodes and which one to send
;184 - Edit clinic moved to ECXSCLD1 due to routine size
D EDIT^ECXSCLD1 ;184
Q
ENDCHK ;check validity of clinic
N ECXB4ARR,ECXAFARR,ECXCHNG ;154
N ECXINST ;184
S ECXCHNG=0 ;154
;154 REMOVED ALL ERROR CHECKING SINCE EDIT OF FIELDS REMOVED **EDIT1 code was moved to ECXSCLD1 for space
;S CODE=$P(^ECX(728.44,CLIEN1,0),U,4)
;K ERR,WRN,ECXERR,WARNING,ERRCHK
;S ERRCHK=0
;D STOP^ECXSTOP(CODE,"DSS Stop Code",CLIEN1) D ERRPRNT
;I $D(ECXERR) S ERRCHK=1
;K ERR,WRN,ECXERR,WARNING
;S CODE=$P(^ECX(728.44,CLIEN1,0),U,5)
;D STOP^ECXSTOP(CODE,"Credit Stop Code",CLIEN1) D ERRPRNT
;I $D(ECXERR) S ERRCHK=1
;W; !!,"...Validity Checker Complete."
;I ERRCHK=1 W !!,"...Errors found please fix." G EDIT1
;remaining fields
;D GETS^DIQ(728.44,CLIEN1,"5;7;8","I","ECXB4ARR")
D GETS^DIQ(728.44,CLIEN1,"5;7;8;14","I","ECXB4ARR") ;184 - Added 14
S DIE=728.44,DA=+CLIEN1,DIE("NO^")="BACKOUTOK" ;166 added restriction to only allow backward jumping or exit from template
;S DR="5//1;S:X'=4 Y=6;7CHAR4 CODE;6///"_DT_";8;10" D ^DIE ;136
S DR="5//5;S:X'=4 Y=13;7CHAR4 CODE;13;8;10;14" D ^DIE ;154,161,166,184 - Added 14
S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^ECX(728.44,CLIEN1,0),U,8)="" ;S $P(^(0),U,7)="" ;154
I $P(^ECX(728.44,DA,0),U,6)=4,$P(^ECX(728.44,DA,0),U,8)="" S $P(^ECX(728.44,DA,0),U,6)=5 ;166 If action to send is 4 (with CHAR4 code) but no CHAR4 code entered, then set action to send to 5
D GETS^DIQ(728.44,CLIEN1,"5;7;8;14","I","ECXAFARR") ;154,184 - Added 14
F I=5,7,8,14 I ECXB4ARR(728.44,CLIEN1_",",I,"I")'=ECXAFARR(728.44,CLIEN1_",",I,"I") S ECXCHNG=1 Q ;154,184 - added 14
I ECXCHNG S $P(^ECX(728.44,CLIEN1,0),U,7)="" ;154
Q
ERRPRNT ;print errors 149 moved to ECXSCLD1 due to size
D ERRPRNT^ECXSCLD1
Q
KILL ;
K I,WARNING,DIC,DIE,DA,DR,DIR,DIRUT,DTOUT,DUOUT,X,Y,ERRCHK
K CLIEN1,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT,ERR,WRN,ECXERR
G EDIT^ECXSCLD1 ;184 - Moved EDIT to ECXSCLC1 due to routine size
;
ERRCHK(CODE,TYPE,CLIEN1) ;check for problems 149 moved to ECXSCLD1 due to size
Q $$ERRCHK^ECXSCLD1(CODE,TYPE,CLIEN1)
;
APPROVE ; approve current DSS Stop and Credit Stop codes
W !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"". Those entries will then be omitted"
W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
K DIR S DIR(0)="Y",DIR("A",1)="Are you ready to approve the reviewed information provided by the",DIR("A")="""Clinic and DSS Stop Codes Print""",DIR("B")="NO"
S DIR("?",1)=" Enter:"
S DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
S DIR("?",3)=" ""NO"" or <RET> if you do not want to approve the current information,"
S DIR("?")=" ""^"" to exit option."
D ^DIR K DIR I 'Y!($D(DIRUT)) G ENDX
W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G ENDX
;
APPLOOP ; queued entry to approve action codes
F EC=0:0 S EC=$O(^ECX(728.44,EC)) Q:'EC I $D(^ECX(728.44,EC,0)) S DA=EC,DIE="^ECX(728.44,",DR="6///"_DT D ^DIE
S ZTREQ="@"
K ^XTMP("ECX UNREVIEWED CLINICS") S ^XTMP("ECX UNREVIEWED CLINICS",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"ECX UNREVIEWED CLINICS"
ENDX K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN,ZTRTN,ZTIO,ZTDESC
K DIR,DIRUT,DTOUT,DUOUT,CLIEN,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT
K J,ECSC,ECSD,ECDATE,ECD,ECN,ECNON,QFLG,PG,LN,SS,POP,%ZIS
K EC,ECD,ECD2,ECL,ECS,ECS2,ECP,ECSC,ECSC2,ECDB,ECDNEW,ECDDIF,ECSCSIGN,ECDF,ECALL,ID,RD,KEY,IEN,FIRST,NAME ;161
;ECXINAC-patch 142 removed variable,it is no longer used
Q
;
PAUSE ;pause screen
N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
S DIR(0)="E" W !! D ^DIR W !!
Q
;
LOOK ;queued entry to check for new clinics
N DAT,ECD0,ECXMISS,ID,ECGRP
S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J)
F EC=0:0 S EC=$O(^SC(EC)) Q:'EC I $D(^SC(EC,0)),$P(^SC(EC,0),U,3)="C",'$D(^ECX(728.44,EC)) S DAT=$G(^SC(EC,"I")) D
.S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q
.S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_" "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1
D ^ECXSCX1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXSCLD 17015 printed Oct 16, 2024@17:54:34 Page 2
ECXSCLD ;BIR/DMA,CML-Enter, Print and Edit Entries in 728.44 ;5/9/17 12:31
+1 ;;3.0;DSS EXTRACTS;**2,8,24,30,71,80,105,112,120,126,132,136,142,144,149,154,161,166,184**;Dec 22, 1997;Build 124
EN ;entry point from option
+1 ;load entries
+2 ;144,161
NEW DIR,X,Y,DIRUT,DTOUT,DUOUT,ZTSK
+3 WRITE !!,"This option creates local entries in the DSS CLINIC AND STOP CODES"
+4 ;144
WRITE !,"file (#728.44).",!
+5 IF '$DATA(^ECX(728.44))
WRITE !,"DSS Clinic stop code file does not exist",!!
READ X:5
KILL X
QUIT
+6 ;W !!,"It also compares file #728.44 to the HOSPITAL LOCATION file (#44) to see" ;144
+7 ;W !,"if there are any differences since the last time the file was reviewed." ;144
+8 ;W !!,"Any differences or new entries will cause an UNREVIEWED CLINICS report" ;144
+9 ;W !,"to automatically print.",! ;144
+10 ;D SELECT^ECXSCLD ;144
+11 ;144 does user hold key?
+12 ;144
IF '$$KCHK^XUSRB("ECXMGR",$GET(DUZ))
Begin DoDot:1
+13 ;144
WRITE !!,?5,"You do not have approved access to this option.",!,"Exiting...",!!
+14 ;144
DO PAUSE
End DoDot:1
GOTO ENDX
+15 ;144
WRITE !,"The CREATE option last ran on ",$SELECT($DATA(^ECX(728.44,"C")):$$FMTE^XLFDT($ORDER(^ECX(728.44,"C"," "),-1),2),1:"- No date on file"),".",!
+16 ;161 Added section for future tasking of create option
SET ZTSK=$ORDER(^XTMP("ECX CREATE",0))
IF ZTSK
Begin DoDot:1
+17 ;see if task is still queued. Delete XTMP if task no longer exists
DO ISQED^%ZTLOAD
IF '$GET(ZTSK(0))
KILL ^XTMP("ECX CREATE")
QUIT
+18 WRITE !,"A future CREATE option is scheduled to run on ",$$HTE^XLFDT($GET(ZTSK("D"))),".",!,"It was scheduled by ",$$GET1^DIQ(200,$GET(ZTSK("DUZ")),.01),".",!
+19 QUIT
End DoDot:1
+20 ;161
SET DIR(0)="SA^N:NOW;Q:QUEUE"
SET DIR("A")="Run the CREATE option (N)ow or (Q)ueue for a future date/time: "
+21 ;161
SET DIR("?",1)="Enter N to run immediately or Q to run in the background at a future date/time."
SET DIR("?")="Enter ^ to skip running the CREATE option."
+22 ;161
DO ^DIR
if $GET(DIRUT)
QUIT
+23 ;161 Get future date/time to run create option
IF Y="Q"
SET ZTSK=$$NODEV^XUTMDEVQ("START^ECXSCLD","DSS CREATE UTILITY",,,1)
if $GET(ZTSK)>0
SET ^XTMP("ECX CREATE",0)=$$FMADD^XLFDT(DT,365)_"^"_DT_"^"_"Create option"
SET ^XTMP("ECX CREATE",ZTSK)=""
QUIT
+24 ;144
WRITE !,"Running CREATE..."
+25 ;144
DO START
+26 ;144
WRITE !!,"The CREATE option has completed on ",$$FMTE^XLFDT($$NOW^XLFDT),".",!
+27 ;144
SET DIR(0)="Y"
SET DIR("A")="Proceed to DSS Clinic and Stop Code Print menu"
SET DIR("B")="NO"
DO ^DIR
+28 ;144
if Y
DO PRINT
+29 QUIT
START ; entry point
+1 NEW ZTREQ
+2 SET EC=0
FOR
SET EC=$ORDER(^SC(EC))
if 'EC
QUIT
DO FIX(EC)
+3 KILL DIK
SET DIK="^ECX(728.44,"
SET DIK(1)=".01^B"
DO ENALL^DIK
+4 SET ZTREQ="@"
+5 ;161 If running in the background, kill of XTMP node
IF $GET(ZTQUEUED)
KILL ^XTMP("ECX CREATE")
+6 QUIT
+7 ;
FIX(EC) ;
+1 ; synchronize files #44 and #728.44.
+2 ;144
NEW DIE,DA,DR
+3 ; differences are placed in ^XTMP("ECX UNREVIEWED CLINICS")
+4 SET EC=$GET(EC)
+5 IF '$DATA(^SC(EC,0))
QUIT
+6 NEW ECD,DAT
+7 SET ECD=^SC(EC,0)
SET DAT=$GET(^SC(EC,"I"))
+8 ;144 Allow updates if entry already exists in 728.44 even if it's no longer a clinic
IF $PIECE(ECD,U,3)'="C"
IF '$DATA(^ECX(728.44,EC,0))
QUIT
+9 ; get stop codes and default style for feeder key
+10 ; 6 if non-count clinic, otherwise 5 - Patch 166, tjl
+11 KILL ECD2,ECS2,ECDNEW,ECDDIF,ECSCSIGN
IF $DATA(^ECX(728.44,EC,0))
SET (ECD2,ECDDIF)=^(0)
SET ECSCSIGN=""
+12 IF $DATA(ECD2)
FOR ECS=2,3,4,5
Begin DoDot:1
+13 SET (ECS2(ECS),X)=$PIECE(ECD2,U,ECS)
+14 KILL DIC,Y
SET DIC=40.7
SET DIC(0)="MXZ"
DO ^DIC
+15 IF +$GET(Y)>0
SET $PIECE(ECS2(ECS),U,2)=$PIECE(^DIC(40.7,+Y,0),U,3)
End DoDot:1
+16 SET ID=+DAT
SET RD=$PIECE(DAT,U,2)
+17 ;change in clinic inactivation for existing entry
+18 IF $DATA(ECD2)
Begin DoDot:1
+19 ;don't include already old inactivated clinics in report
+20 IF ID
IF ID'>DT
IF ('RD)!(RD>DT)
IF $PIECE(ECD2,U,10)'=ID
Begin DoDot:2
+21 SET $PIECE(ECD2,U,7)=""
SET $PIECE(ECD2,U,10)=ID
SET ECSCSIGN="*"
End DoDot:2
+22 IF ID
IF RD
IF (RD'>DT)
IF $PIECE(ECD2,U,10)
Begin DoDot:2
+23 SET $PIECE(ECD2,U,7)=""
SET $PIECE(ECD2,U,10)=""
SET ECSCSIGN="r"
End DoDot:2
+24 IF ID
IF (ID>DT)
IF $PIECE(ECD2,U,10)
Begin DoDot:2
+25 SET $PIECE(ECD2,U,7)=""
SET $PIECE(ECD2,U,10)=""
SET ECSCSIGN="!"
End DoDot:2
+26 IF 'ID
IF $PIECE(ECD2,U,10)
Begin DoDot:2
+27 SET $PIECE(ECD2,U,7)=""
SET $PIECE(ECD2,U,10)=""
SET ECSCSIGN="!"
End DoDot:2
+28 SET ECDDIF=ECD2
End DoDot:1
+29 ;setup for stops
+30 FOR ECS=7,18
SET ECP=+$PIECE(ECD,U,ECS)
SET ECS(ECS)=$PIECE($GET(^DIC(40.7,ECP,0)),U,2)_U_$PIECE($GET(^DIC(40.7,ECP,0)),U,3)
+31 ;161,166 tjl - Default for "OOS" clinics should be 5, not 6
SET ECDF=5
if $PIECE(ECD,U,17)="Y"
SET ECDF=6
if $GET(^SC(EC,"OOS"))
SET ECDF=5
+32 ;154 added DSS SC CSC
SET ECDB=EC_U_$SELECT(+ECS(7):+ECS(7),1:"")_U_$SELECT(+ECS(18):+ECS(18),1:"")_U_$SELECT(+ECS(7):+ECS(7),1:"")_U_$SELECT(+ECS(18):+ECS(18),1:"")
+33 ;new entry
+34 IF '$DATA(ECD2)
Begin DoDot:1
+35 ;154
SET $PIECE(^ECX(728.44,EC,0),U,1,5)=ECDB
+36 ;S $P(^ECX(728.44,EC,0),U,1,5)=ECDB_U_$S(+ECS(7):+ECS(7),1:"")_U_$S(+ECS(18):+ECS(18),1:"")
+37 SET $PIECE(^(0),U,6)=ECDF
SET $PIECE(^(0),U,12)=$PIECE(ECD,U,17)
+38 SET ECDNEW=^ECX(728.44,EC,0)
End DoDot:1
+39 ;changes to existing entry
+40 IF $DATA(ECD2)
Begin DoDot:1
+41 ;154 ADDED DSS SC CSC
SET $PIECE(ECD2,U,1,5)=ECDB
SET $PIECE(ECDDIF,U,1,3)=ECDB
+42 ;differs in stop code
+43 ;W !," SC ",?10,X,?20,ECS(7),?40,ECS2(2)
IF +ECS(7)'=+ECS2(2)
SET $PIECE(ECD2,U,7)=""
SET X=$PIECE(ECDDIF,U,2)_"!"
SET $PIECE(ECDDIF,U,2)=X
+44 ;154 added DSS STOP CODE
+45 ;W !,"DSS SC ",?10,X,?20,ECS(7),?40,ECS2(4)
IF +ECS(7)'=+ECS2(4)
SET $PIECE(ECD2,U,7)=""
SET X=$PIECE(ECDDIF,U,4)_"!"
SET $PIECE(ECDDIF,U,4)=X
+46 ;differs in credit stop code
+47 IF +ECS(18)'=+ECS2(3)
SET $PIECE(ECD2,U,7)=""
SET X=$PIECE(ECDDIF,U,3)_"!"
SET $PIECE(ECDDIF,U,3)=X
+48 ;154 added DSS CREDIT STOP CODE
+49 ; W !,"DSS CSC",!
IF +ECS(18)'=+ECS2(5)
SET $PIECE(ECD2,U,7)=""
SET X=$PIECE(ECDDIF,U,5)_"!"
SET $PIECE(ECDDIF,U,5)=X
+50 ;change in non-count
+51 IF $PIECE(ECD2,U,12)'=$PIECE(ECD,U,17)
SET X=$PIECE(ECD,U,17)_"!"
SET $PIECE(ECDDIF,U,12)=X
SET $PIECE(ECD2,U,12)=$PIECE(ECD,U,17)
SET $PIECE(ECD2,U,7)=""
+52 ;reset entry
+53 SET ^ECX(728.44,EC,0)=ECD2
End DoDot:1
+54 ;set tmp node
+55 SET ECSC=$PIECE(ECD,U)
if $LENGTH(ECSC)>27
SET ECSC=$EXTRACT(ECSC,1,27)
+56 IF $DATA(ECD2)
IF $PIECE(ECD2,U,7)=""
Begin DoDot:1
+57 IF $DATA(^XTMP("ECX UNREVIEWED CLINICS",ECSC))
DO UPDATE(ECSC,ECDDIF,ECSCSIGN)
+58 IF '$DATA(^XTMP("ECX UNREVIEWED CLINICS",ECSC))
SET ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=ECSCSIGN_U_$PIECE(ECDDIF,U,2,200)
SET ^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT()
End DoDot:1
+59 IF $DATA(ECDNEW)
SET ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=""_U_$PIECE(ECDNEW,U,2,200)
SET ^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT()
+60 ;144 Set create date to today's date
SET DIE=728.44
SET DA=EC
SET DR="12///TODAY"
DO ^DIE
+61 QUIT
+62 ;
UPDATE(ECSC,ECDDIF,ECSCSIGN) ;update ^xtmp node with today's changes
+1 NEW ECXOLD,J,L1,L2,X,X1,X2
+2 SET ECXOLD=^XTMP("ECX UNREVIEWED CLINICS",ECSC)
+3 FOR J=2,3,4,5
SET X1=+$PIECE(ECXOLD,U,J)
SET X2=+$PIECE(ECDDIF,U,J)
IF X2=X1
IF $PIECE(ECDDIF,U,J)'=$PIECE(ECXOLD,U,J)
Begin DoDot:1
+4 SET L1=$LENGTH($PIECE(ECXOLD,U,J))
SET L2=$LENGTH($PIECE(ECDDIF,U,J))
+5 IF L1>L2
SET $PIECE(ECDDIF,U,J)=$PIECE(ECXOLD,U,J)
End DoDot:1
+6 SET X1=$EXTRACT($PIECE(ECXOLD,U,12),1)
SET X2=$EXTRACT($PIECE(ECDDIF,U,12),1)
IF X2=X1
SET $PIECE(ECDDIF,U,12)=$PIECE(ECXOLD,U,12)
+7 SET X1=$PIECE(ECXOLD,U)
SET X=X1_U_$PIECE(ECDDIF,U,2,200)
+8 IF ECSCSIGN'=""
IF ECSCSIGN'=X1
SET X=ECSCSIGN_U_$PIECE(ECDDIF,U,2,200)
+9 SET ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=X
+10 QUIT
+11 ;
SELECT ;select IO device to 'gather clinic stop codes' and print 'unreviewd clinics' report;
+1 ;for menu option 'Create DSS Clinic Stop Code File' or 'Clinics and DSS Stop Codes Print'
+2 NEW DIR,ECALL,IOP,POP,XX,ZTIO,ZTRTN,ZTDESC,ZTSK,ZTSAVE
+3 ;does user hold key?
+4 IF '$$KCHK^XUSRB("ECXMGR",$GET(DUZ))
Begin DoDot:1
+5 WRITE !!,?5,"You do not have approved access to this option.",!,"Exiting...",!!
+6 DO PAUSE
End DoDot:1
GOTO ENDX
+7 WRITE !,"Please select a print device for the 'Unreviewed Clinics' report."
+8 WRITE !,"**Please note: If printing in foreground, synching files may cause screen delay."
+9 WRITE !
SET %ZIS="Q"
DO ^%ZIS
+10 IF POP
QUIT
+11 ;queue the report
+12 IF $DATA(IO("Q"))
Begin DoDot:1
+13 KILL ZTSAVE
SET ZTDESC="Gather Clinic Stop Codes for DSS"
SET ZTRTN="START^ECXSCLD"
+14 DO ^%ZTLOAD
+15 IF $GET(ZTSK)
WRITE !,"Queued as Task #: "_ZTSK
DO ENDX
DO PAUSE
End DoDot:1
QUIT
+16 WRITE !!,">> Synchronizing Stop Codes file (#728.44) with the Hospital"
+17 WRITE !," Location file (#44)...",!
+18 DO START
+19 DO ^%ZISC
DO HOME^%ZIS
KILL IO("Q")
+20 QUIT
+21 ;
PRINT ; print worksheet for updates
+1 NEW OUT,DIR,ECALL,ECXMCA,ECXCLX
+2 IF '$ORDER(^ECX(728.44,0))
WRITE !,"DSS Clinic stop code file does not exist",!!
READ X:5
KILL X
QUIT
+3 WRITE !!,"This option produces a worksheet of (A) All Clinics, (C) Active, (D) Duplicate, (I) Inactive, "
+4 WRITE !,"or only the (U) Unreviewed Clinics that are awaiting approval."
+5 WRITE !!,"Clinics that were defined as ""inactive"" by MAS/HAS the last time the"
+6 WRITE !,"option ""Create DSS Clinic Stop Code File"" was run will be indicated with",!,"an ""*""."
+7 WRITE !!,"Choose (X) for exporting the CLINICS AND STOP CODES FILE to a text file for"
+8 WRITE !,"spreadsheet use.",!
+9 ;144
WRITE !,"**REMINDER - The CREATE option last ran on ",$SELECT($DATA(^ECX(728.44,"C")):$$FMTE^XLFDT($ORDER(^ECX(728.44,"C"," "),-1),2),1:"- No date on file"),"."
+10 ;144
WRITE !,"If the most recent clinic changes from the HOSPITAL LOCATION file #44",!,"are desired, run the CREATE option before running a report.**",!
+11 ;149
SET DIR(0)="S^A:ALL CLINICS;C:ALL ACTIVE CLINICS;D:DUPLICATE CLINICS;I:ALL INACTIVE CLINICS;U:UNREVIEWED CLINICS;X:EXPORT TO TEXT FILE FOR SPREADSHEET USE"
SET DIR("A")="Enter ""A"", ""C"", ""D"", ""I"", ""U"", or ""X"""
+12 SET DIR("?",1)="Enter: ""C"" to print a worksheet of all active DSS Clinic Stops,"
+13 SET DIR("?",2)="Enter: ""I"" to print a worksheet of all inactive DSS Clinic Stops,"
+14 SET DIR("?",3)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,"
+15 SET DIR("?",4)="Enter: ""U"" to print only the Clinic Stops that have not been approved."
+16 ;149
SET DIR("?",5)="Enter: ""D"" to print the Duplicate Clinics found."
+17 SET DIR("?")="Enter: ""X"" to export CLINICS AND STOP CODES FILE to a text file."
+18 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO ENDX
SET ECALL=$EXTRACT(Y)
+19 IF ECALL="X"
DO EXPORT^ECXSCLD1
QUIT
+20 ;161
IF ECALL'="D"
WRITE !!,"**REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY**",!
+21 SET %ZIS="Q"
DO ^%ZIS
if POP
QUIT
+22 IF $DATA(IO("Q"))
KILL ZTSAVE
SET ZTDESC="DSS clinic stop code work sheet"
SET ZTRTN="SPRINT^ECXSCLD"
SET ZTSAVE("ECALL")=""
DO ^%ZTLOAD
DO HOME^%ZIS
QUIT
SPRINT ; queued entry to print work sheet
+1 ;149
NEW DC,ECSDC,DIV1,DIV2,APPL,APPL1,APPL2,STOPC,CREDSC,NATC,DUPIEN,FIEN,ECSC,ECSCI,ECSC2
+2 ;184
NEW ECSTA6A
+3 USE IO
+4 ;161
SET QFLG=0
SET $PIECE(LN,"-",$SELECT(ECALL="D":80,1:132))=""
SET PG=0
+5 SET ECDATE=$ORDER(^ECX(728.44,"A1",""))
IF ECDATE
SET ECDATE=-ECDATE
SET ECDATE=$$FMTE^XLFDT(ECDATE,"5DF")
SET ECDATE=$TRANSLATE(ECDATE," ","0")
+6 ;144
KILL ^TMP("EC",$JOB)
+7 IF ECALL'="D"
Begin DoDot:1
+8 FOR J=0:0
SET J=$ORDER(^ECX(728.44,J))
if 'J
QUIT
IF $DATA(^ECX(728.44,J,0))
SET ECSD=^ECX(728.44,J,0)
Begin DoDot:2
+9 ;144 Don't include entries that aren't clinic types
IF $PIECE($GET(^SC(J,0)),U,3)'="C"
QUIT
+10 IF ECALL="A"
IF $DATA(^SC(J,0))
SET ECSC=$PIECE(^SC(J,0),U)
SET ^TMP("EC",$JOB,ECSC)=$PIECE(ECSD,U,2,200)
+11 IF (ECALL="I")
IF ($PIECE(ECSD,U,10))
IF $DATA(^SC(J,0))
SET ECSC=$PIECE(^SC(J,0),U)
SET ^TMP("EC",$JOB,ECSC)=$PIECE(ECSD,U,2,200)
+12 IF ((ECALL="C")&($PIECE(ECSD,U,10)=""))!((ECALL="C")&($PIECE(ECSD,U,10)>DT))
IF $DATA(^SC(J,0))
SET ECSC=$PIECE(^(0),U)
SET ^TMP("EC",$JOB,ECSC)=$PIECE(ECSD,U,2,200)
+13 ;144
IF ECALL="U"
IF $PIECE(ECSD,U,7)=""
IF $DATA(^SC(J,0))
SET ECSC=$PIECE(^SC(J,0),U)
SET ^TMP("EC",$JOB,ECSC)=$PIECE(ECSD,U,2,200)
End DoDot:2
+14 ;144
DO HEAD
SET ECSC=""
IF $ORDER(^TMP("EC",$JOB,ECSC))=""
WRITE !!,"NO DATA FOUND FOR WORKSHEET.",!
QUIT
+15 ;149
IF ECALL'="D"
Begin DoDot:2
+16 ;149
FOR J=1:1
SET ECSC=$ORDER(^TMP("EC",$JOB,ECSC))
if ECSC=""
QUIT
SET ECD=^TMP("EC",$JOB,ECSC)
DO SHOWEM
if QFLG
QUIT
End DoDot:2
End DoDot:1
+17 IF ECALL="D"
Begin DoDot:1
+18 SET FIRST=1
+19 FOR DC=0:0
SET DC=$ORDER(^ECX(728.44,DC))
if 'DC
QUIT
IF $DATA(^ECX(728.44,DC,0))
SET ECSDC=^ECX(728.44,DC,0)
Begin DoDot:2
+20 ;149 Don't include non clinic types or inactive ones
IF $PIECE($GET(^SC(DC,0)),U,3)'="C"!($PIECE(^ECX(728.44,DC,0),U,10)'="")
QUIT
+21 IF $DATA(^SC(DC,0))
Begin DoDot:3
+22 ;154 CVW
SET STOPC=$PIECE(ECSDC,U,2)
SET CREDSC=$PIECE(ECSDC,U,3)
SET NATC=$PIECE(ECSDC,U,8)
+23 ;166
SET DIV=$$GET1^DIQ(44,$PIECE(ECSDC,U),3.5,"I")
SET APPL=$$GET1^DIQ(44,$PIECE(ECSDC,U),1912,"I")
SET ECXMCA=$$GET1^DIQ(728.442,$PIECE(ECSDC,U,14),.01)
+24 ;184
SET ECSTA6A=$$GET1^DIQ(4,$PIECE(ECSDC,U,15),99,"E")
+25 IF 'FIRST
Begin DoDot:4
+26 ;166
IF $DATA(^TMP("EC",$JOB,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA))
Begin DoDot:5
+27 ;166
SET ^TMP("EC",$JOB,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,0)="1"
End DoDot:5
End DoDot:4
+28 ;166 ,184 - added STA6A
SET ECSC=$PIECE(^SC(DC,0),U)
SET ^TMP("EC",$JOB,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,DC,ECSC)=ECSC_U_DC_U_STOPC_U_CREDSC_U_$$GET1^DIQ(728.441,NATC,.01)_U_ECXMCA_U_APPL_U_DIV_U_ECSTA6A
End DoDot:3
+29 IF FIRST
Begin DoDot:3
+30 ;166,184 - Added STA6A
SET ECSC=$PIECE(^SC(DC,0),U)
SET ^TMP("EC",$JOB,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,DC,ECSC)=ECSC_U_DC_U_STOPC_U_CREDSC_U_$$GET1^DIQ(728.441,NATC,.01)_U_ECXMCA_U_APPL_U_DIV_U_ECSTA6A
SET FIRST=0
End DoDot:3
End DoDot:2
+31 ;144
DO HEAD
SET ECSC=""
IF $ORDER(^TMP("EC",$JOB,ECSC))=""
WRITE !!,"NO DATA FOUND FOR WORKSHEET.",!
QUIT
End DoDot:1
+32 IF ECALL="D"
Begin DoDot:1
+33 SET KEY=""
FOR
SET KEY=$ORDER(^TMP("EC",$JOB,KEY))
if '+KEY
QUIT
IF $GET(^TMP("EC",$JOB,KEY,0))
if QFLG
QUIT
Begin DoDot:2
+34 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("EC",$JOB,KEY,IEN))
if '+IEN!(QFLG)
QUIT
SET NAME=""
FOR
SET NAME=$ORDER(^TMP("EC",$JOB,KEY,IEN,NAME))
if NAME=""!(QFLG)
QUIT
Begin DoDot:3
+35 IF $Y+6>IOSL
DO HEAD
if QFLG
QUIT
+36 ;166
SET ECXCLX=^TMP("EC",$JOB,KEY,IEN,NAME)
+37 ;161,166
WRITE !,$PIECE(ECXCLX,U)
+38 ;161,166
WRITE ?32,$PIECE(ECXCLX,U,2),?44,$PIECE(ECXCLX,U,3),?50,$PIECE(ECXCLX,U,4),?55,$PIECE(ECXCLX,U,5),?61,$PIECE(ECXCLX,U,6)
+39 ;161,166
WRITE ?67,$PIECE(^TMP("EC",$JOB,KEY,IEN,NAME),U,7),?76,$PIECE(^TMP("EC",$JOB,KEY,IEN,NAME),U,8)
+40 ;184
WRITE ?82,$PIECE(^TMP("EC",$JOB,KEY,IEN,NAME),U,9)
End DoDot:3
+41 if QFLG
QUIT
WRITE !
+42 IF $Y+6>IOSL
DO HEAD
if QFLG
QUIT
End DoDot:2
End DoDot:1
+43 ;144
KILL ^TMP("EC",$JOB)
+44 ;161
IF $EXTRACT(IOST)="C"
IF 'QFLG
DO SS^ECXSCLD1
+45 ;161
DO ENDX
+46 if $Y
WRITE @IOF
DO ^%ZISC
SET ZTREQ="@"
+47 QUIT
HEAD ; header for worksheet 149 moved to ECXSCLD1 due to size
+1 DO HEAD^ECXSCLD1
+2 QUIT
+3 ;
SHOWEM ; list clinics for worksheet 149 moved to ECXSCLD1 due to size
+1 DO SHOWEM^ECXSCLD1
+2 QUIT
EDIT ; put in DSS stopcodes and which one to send
+1 ;184 - Edit clinic moved to ECXSCLD1 due to routine size
+2 ;184
DO EDIT^ECXSCLD1
+3 QUIT
ENDCHK ;check validity of clinic
+1 ;154
NEW ECXB4ARR,ECXAFARR,ECXCHNG
+2 ;184
NEW ECXINST
+3 ;154
SET ECXCHNG=0
+4 ;154 REMOVED ALL ERROR CHECKING SINCE EDIT OF FIELDS REMOVED **EDIT1 code was moved to ECXSCLD1 for space
+5 ;S CODE=$P(^ECX(728.44,CLIEN1,0),U,4)
+6 ;K ERR,WRN,ECXERR,WARNING,ERRCHK
+7 ;S ERRCHK=0
+8 ;D STOP^ECXSTOP(CODE,"DSS Stop Code",CLIEN1) D ERRPRNT
+9 ;I $D(ECXERR) S ERRCHK=1
+10 ;K ERR,WRN,ECXERR,WARNING
+11 ;S CODE=$P(^ECX(728.44,CLIEN1,0),U,5)
+12 ;D STOP^ECXSTOP(CODE,"Credit Stop Code",CLIEN1) D ERRPRNT
+13 ;I $D(ECXERR) S ERRCHK=1
+14 ;W; !!,"...Validity Checker Complete."
+15 ;I ERRCHK=1 W !!,"...Errors found please fix." G EDIT1
+16 ;remaining fields
+17 ;D GETS^DIQ(728.44,CLIEN1,"5;7;8","I","ECXB4ARR")
+18 ;184 - Added 14
DO GETS^DIQ(728.44,CLIEN1,"5;7;8;14","I","ECXB4ARR")
+19 ;166 added restriction to only allow backward jumping or exit from template
SET DIE=728.44
SET DA=+CLIEN1
SET DIE("NO^")="BACKOUTOK"
+20 ;S DR="5//1;S:X'=4 Y=6;7CHAR4 CODE;6///"_DT_";8;10" D ^DIE ;136
+21 ;154,161,166,184 - Added 14
SET DR="5//5;S:X'=4 Y=13;7CHAR4 CODE;13;8;10;14"
DO ^DIE
+22 ;S $P(^(0),U,7)="" ;154
if $PIECE(^ECX(728.44,DA,0),U,6)'=4
SET $PIECE(^ECX(728.44,CLIEN1,0),U,8)=""
+23 ;166 If action to send is 4 (with CHAR4 code) but no CHAR4 code entered, then set action to send to 5
IF $PIECE(^ECX(728.44,DA,0),U,6)=4
IF $PIECE(^ECX(728.44,DA,0),U,8)=""
SET $PIECE(^ECX(728.44,DA,0),U,6)=5
+24 ;154,184 - Added 14
DO GETS^DIQ(728.44,CLIEN1,"5;7;8;14","I","ECXAFARR")
+25 ;154,184 - added 14
FOR I=5,7,8,14
IF ECXB4ARR(728.44,CLIEN1_",",I,"I")'=ECXAFARR(728.44,CLIEN1_",",I,"I")
SET ECXCHNG=1
QUIT
+26 ;154
IF ECXCHNG
SET $PIECE(^ECX(728.44,CLIEN1,0),U,7)=""
+27 QUIT
ERRPRNT ;print errors 149 moved to ECXSCLD1 due to size
+1 DO ERRPRNT^ECXSCLD1
+2 QUIT
KILL ;
+1 KILL I,WARNING,DIC,DIE,DA,DR,DIR,DIRUT,DTOUT,DUOUT,X,Y,ERRCHK
+2 KILL CLIEN1,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT,ERR,WRN,ECXERR
+3 ;184 - Moved EDIT to ECXSCLC1 due to routine size
GOTO EDIT^ECXSCLD1
+4 ;
ERRCHK(CODE,TYPE,CLIEN1) ;check for problems 149 moved to ECXSCLD1 due to size
+1 QUIT $$ERRCHK^ECXSCLD1(CODE,TYPE,CLIEN1)
+2 ;
APPROVE ; approve current DSS Stop and Credit Stop codes
+1 WRITE !!,"This option allows you to mark the current clinic entries in the CLINICS AND",!,"STOP CODES file (#728.44) as ""reviewed"". Those entries will then be omitted"
+2 WRITE !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("A",1)="Are you ready to approve the reviewed information provided by the"
SET DIR("A")="""Clinic and DSS Stop Codes Print"""
SET DIR("B")="NO"
+4 SET DIR("?",1)=" Enter:"
+5 SET DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
+6 SET DIR("?",3)=" ""NO"" or <RET> if you do not want to approve the current information,"
+7 SET DIR("?")=" ""^"" to exit option."
+8 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))
GOTO ENDX
+9 WRITE !
SET ZTRTN="APPLOOP^ECXSCLD"
SET ZTIO=""
SET ZTDESC="Approve DSS stop codes for clinic extract"
DO ^%ZTLOAD
WRITE !!,"...approval queued"
GOTO ENDX
+10 ;
APPLOOP ; queued entry to approve action codes
+1 FOR EC=0:0
SET EC=$ORDER(^ECX(728.44,EC))
if 'EC
QUIT
IF $DATA(^ECX(728.44,EC,0))
SET DA=EC
SET DIE="^ECX(728.44,"
SET DR="6///"_DT
DO ^DIE
+2 SET ZTREQ="@"
+3 KILL ^XTMP("ECX UNREVIEWED CLINICS")
SET ^XTMP("ECX UNREVIEWED CLINICS",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"ECX UNREVIEWED CLINICS"
ENDX KILL X,Y,DA,DR,DIC,DIE,QFLG,PG,LN,ZTRTN,ZTIO,ZTDESC
+1 KILL DIR,DIRUT,DTOUT,DUOUT,CLIEN,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT
+2 KILL J,ECSC,ECSD,ECDATE,ECD,ECN,ECNON,QFLG,PG,LN,SS,POP,%ZIS
+3 ;161
KILL EC,ECD,ECD2,ECL,ECS,ECS2,ECP,ECSC,ECSC2,ECDB,ECDNEW,ECDDIF,ECSCSIGN,ECDF,ECALL,ID,RD,KEY,IEN,FIRST,NAME
+4 ;ECXINAC-patch 142 removed variable,it is no longer used
+5 QUIT
+6 ;
PAUSE ;pause screen
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
+2 SET DIR(0)="E"
WRITE !!
DO ^DIR
WRITE !!
+3 QUIT
+4 ;
LOOK ;queued entry to check for new clinics
+1 NEW DAT,ECD0,ECXMISS,ID,ECGRP
+2 SET ECD=$EXTRACT(DT,1,5)-1-($EXTRACT(DT,4,5)="01"*8800)
SET ECD0=ECD_"00"
SET ECXMISS=10
SET ECGRP="SCX"
KILL ^TMP("ECXS",$JOB)
+3 FOR EC=0:0
SET EC=$ORDER(^SC(EC))
if 'EC
QUIT
IF $DATA(^SC(EC,0))
IF $PIECE(^SC(EC,0),U,3)="C"
IF '$DATA(^ECX(728.44,EC))
SET DAT=$GET(^SC(EC,"I"))
Begin DoDot:1
+4 SET ID=+DAT
SET RD=$PIECE(DAT,U,2)
IF ID
IF ID<DT
IF 'RD!(RD>DT)
QUIT
+5 SET ^TMP("ECXS",$JOB,ECXMISS,0)=$JUSTIFY(EC,6)_" "_$$LJ^XLFSTR($PIECE(^SC(EC,0),U),40)
SET ECXMISS=ECXMISS+1
End DoDot:1
+6 DO ^ECXSCX1
+7 QUIT
