- 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,190**;Dec 22, 1997;Build 36
- 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 ""*"".",!
- ;190 - Remove all other print options; report is now Export only
- ;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)
- S ECALL="X" D EXPORT^ECXSCLD1 Q ;190 - Set ECALL to "X" to make sure we don't break anythign else
- ;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 17173 printed Jan 18, 2025@02:55:02 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,190**;Dec 22, 1997;Build 36
- 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 ;W !!,"Clinics that were defined as ""inactive"" by MAS/HAS the last time the"
- +6 ;W !,"option ""Create DSS Clinic Stop Code File"" was run will be indicated with",!,"an ""*"".",!
- +7 ;190 - Remove all other print options; report is now Export only
- +8 ;W !!,"Choose (X) for exporting the CLINICS AND STOP CODES FILE to a text file for"
- +9 ;W !,"spreadsheet use.",!
- +10 ;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"),"."
- +11 ;144
- WRITE !,"If the most recent clinic changes from the HOSPITAL LOCATION file #44",!,"are desired, run the CREATE option before running a report.**",!
- +12 ;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
- +13 ;S DIR("?",1)="Enter: ""C"" to print a worksheet of all active DSS Clinic Stops,"
- +14 ;S DIR("?",2)="Enter: ""I"" to print a worksheet of all inactive DSS Clinic Stops,"
- +15 ;S DIR("?",3)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,"
- +16 ;S DIR("?",4)="Enter: ""U"" to print only the Clinic Stops that have not been approved."
- +17 ;S DIR("?",5)="Enter: ""D"" to print the Duplicate Clinics found." ;149
- +18 ;S DIR("?")="Enter: ""X"" to export CLINICS AND STOP CODES FILE to a text file."
- +19 ;D ^DIR K DIR G ENDX:$D(DIRUT) S ECALL=$E(Y)
- +20 ;190 - Set ECALL to "X" to make sure we don't break anythign else
- SET ECALL="X"
- DO EXPORT^ECXSCLD1
- QUIT
- +21 ;I ECALL'="D" W !!,"**REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY**",! ;161
- +22 ;S %ZIS="Q" D ^%ZIS Q:POP
- +23 ;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
- +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