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

ECXSCLD.m

Go to the documentation of this file.
  1. 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
  1. EN ;entry point from option
  1. ;load entries
  1. N DIR,X,Y,DIRUT,DTOUT,DUOUT,ZTSK ;144,161
  1. W !!,"This option creates local entries in the DSS CLINIC AND STOP CODES"
  1. W !,"file (#728.44).",! ;144
  1. I '$D(^ECX(728.44)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
  1. ;W !!,"It also compares file #728.44 to the HOSPITAL LOCATION file (#44) to see" ;144
  1. ;W !,"if there are any differences since the last time the file was reviewed." ;144
  1. ;W !!,"Any differences or new entries will cause an UNREVIEWED CLINICS report" ;144
  1. ;W !,"to automatically print.",! ;144
  1. ;D SELECT^ECXSCLD ;144
  1. ;144 does user hold key?
  1. I '$$KCHK^XUSRB("ECXMGR",$G(DUZ)) D G ENDX ;144
  1. .W !!,?5,"You do not have approved access to this option.",!,"Exiting...",!! ;144
  1. .D PAUSE ;144
  1. 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
  1. S ZTSK=$O(^XTMP("ECX CREATE",0)) I ZTSK D ;161 Added section for future tasking of create option
  1. .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
  1. .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),".",!
  1. .Q
  1. 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
  1. 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
  1. D ^DIR Q:$G(DIRUT) ;161
  1. 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
  1. W !,"Running CREATE..." ;144
  1. D START ;144
  1. W !!,"The CREATE option has completed on ",$$FMTE^XLFDT($$NOW^XLFDT),".",! ;144
  1. S DIR(0)="Y",DIR("A")="Proceed to DSS Clinic and Stop Code Print menu",DIR("B")="NO" D ^DIR ;144
  1. D:Y PRINT ;144
  1. Q
  1. START ; entry point
  1. N ZTREQ
  1. S EC=0 F S EC=$O(^SC(EC)) Q:'EC D FIX(EC)
  1. K DIK S DIK="^ECX(728.44,",DIK(1)=".01^B" D ENALL^DIK
  1. S ZTREQ="@"
  1. I $G(ZTQUEUED) K ^XTMP("ECX CREATE") ;161 If running in the background, kill of XTMP node
  1. Q
  1. ;
  1. FIX(EC) ;
  1. ; synchronize files #44 and #728.44.
  1. N DIE,DA,DR ;144
  1. ; differences are placed in ^XTMP("ECX UNREVIEWED CLINICS")
  1. S EC=$G(EC)
  1. I '$D(^SC(EC,0)) Q
  1. N ECD,DAT
  1. S ECD=^SC(EC,0),DAT=$G(^SC(EC,"I"))
  1. 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
  1. ; get stop codes and default style for feeder key
  1. ; 6 if non-count clinic, otherwise 5 - Patch 166, tjl
  1. K ECD2,ECS2,ECDNEW,ECDDIF,ECSCSIGN I $D(^ECX(728.44,EC,0)) S (ECD2,ECDDIF)=^(0),ECSCSIGN=""
  1. I $D(ECD2) F ECS=2,3,4,5 D
  1. .S (ECS2(ECS),X)=$P(ECD2,U,ECS)
  1. .K DIC,Y S DIC=40.7,DIC(0)="MXZ" D ^DIC
  1. .I +$G(Y)>0 S $P(ECS2(ECS),U,2)=$P(^DIC(40.7,+Y,0),U,3)
  1. S ID=+DAT,RD=$P(DAT,U,2)
  1. ;change in clinic inactivation for existing entry
  1. I $D(ECD2) D
  1. .;don't include already old inactivated clinics in report
  1. .I ID,ID'>DT I ('RD)!(RD>DT) I $P(ECD2,U,10)'=ID D
  1. ..S $P(ECD2,U,7)="",$P(ECD2,U,10)=ID,ECSCSIGN="*"
  1. .I ID,RD,(RD'>DT) I $P(ECD2,U,10) D
  1. ..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="r"
  1. .I ID,(ID>DT) I $P(ECD2,U,10) D
  1. ..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="!"
  1. .I 'ID,$P(ECD2,U,10) D
  1. ..S $P(ECD2,U,7)="",$P(ECD2,U,10)="",ECSCSIGN="!"
  1. .S ECDDIF=ECD2
  1. ;setup for stops
  1. 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)
  1. 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
  1. 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
  1. ;new entry
  1. I '$D(ECD2) D
  1. .S $P(^ECX(728.44,EC,0),U,1,5)=ECDB ;154
  1. .;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:"")
  1. .S $P(^(0),U,6)=ECDF,$P(^(0),U,12)=$P(ECD,U,17)
  1. .S ECDNEW=^ECX(728.44,EC,0)
  1. ;changes to existing entry
  1. I $D(ECD2) D
  1. .S $P(ECD2,U,1,5)=ECDB,$P(ECDDIF,U,1,3)=ECDB ;154 ADDED DSS SC CSC
  1. .;differs in stop code
  1. .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)
  1. .;154 added DSS STOP CODE
  1. .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)
  1. .;differs in credit stop code
  1. .I +ECS(18)'=+ECS2(3) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,3)_"!",$P(ECDDIF,U,3)=X
  1. .;154 added DSS CREDIT STOP CODE
  1. .I +ECS(18)'=+ECS2(5) S $P(ECD2,U,7)="",X=$P(ECDDIF,U,5)_"!",$P(ECDDIF,U,5)=X ; W !,"DSS CSC",!
  1. .;change in non-count
  1. .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)=""
  1. .;reset entry
  1. .S ^ECX(728.44,EC,0)=ECD2
  1. ;set tmp node
  1. S ECSC=$P(ECD,U) S:$L(ECSC)>27 ECSC=$E(ECSC,1,27)
  1. I $D(ECD2),$P(ECD2,U,7)="" D
  1. .I $D(^XTMP("ECX UNREVIEWED CLINICS",ECSC)) D UPDATE(ECSC,ECDDIF,ECSCSIGN)
  1. .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()
  1. I $D(ECDNEW) S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=""_U_$P(ECDNEW,U,2,200),^XTMP("ECX UNREVIEWED CLINICS",ECSC,"T")=$$NOW^XLFDT()
  1. S DIE=728.44,DA=EC,DR="12///TODAY" D ^DIE ;144 Set create date to today's date
  1. Q
  1. ;
  1. UPDATE(ECSC,ECDDIF,ECSCSIGN) ;update ^xtmp node with today's changes
  1. N ECXOLD,J,L1,L2,X,X1,X2
  1. S ECXOLD=^XTMP("ECX UNREVIEWED CLINICS",ECSC)
  1. 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
  1. .S L1=$L($P(ECXOLD,U,J)),L2=$L($P(ECDDIF,U,J))
  1. .I L1>L2 S $P(ECDDIF,U,J)=$P(ECXOLD,U,J)
  1. 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)
  1. S X1=$P(ECXOLD,U),X=X1_U_$P(ECDDIF,U,2,200)
  1. I ECSCSIGN'="",ECSCSIGN'=X1 S X=ECSCSIGN_U_$P(ECDDIF,U,2,200)
  1. S ^XTMP("ECX UNREVIEWED CLINICS",ECSC)=X
  1. Q
  1. ;
  1. 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'
  1. N DIR,ECALL,IOP,POP,XX,ZTIO,ZTRTN,ZTDESC,ZTSK,ZTSAVE
  1. ;does user hold key?
  1. I '$$KCHK^XUSRB("ECXMGR",$G(DUZ)) D G ENDX
  1. .W !!,?5,"You do not have approved access to this option.",!,"Exiting...",!!
  1. .D PAUSE
  1. W !,"Please select a print device for the 'Unreviewed Clinics' report."
  1. W !,"**Please note: If printing in foreground, synching files may cause screen delay."
  1. W ! S %ZIS="Q" D ^%ZIS
  1. I POP Q
  1. ;queue the report
  1. I $D(IO("Q")) D Q
  1. . K ZTSAVE S ZTDESC="Gather Clinic Stop Codes for DSS",ZTRTN="START^ECXSCLD"
  1. . D ^%ZTLOAD
  1. . I $G(ZTSK) W !,"Queued as Task #: "_ZTSK D ENDX D PAUSE
  1. W !!,">> Synchronizing Stop Codes file (#728.44) with the Hospital"
  1. W !," Location file (#44)...",!
  1. D START
  1. D ^%ZISC,HOME^%ZIS K IO("Q")
  1. Q
  1. ;
  1. PRINT ; print worksheet for updates
  1. N OUT,DIR,ECALL,ECXMCA,ECXCLX
  1. I '$O(^ECX(728.44,0)) W !,"DSS Clinic stop code file does not exist",!! R X:5 K X Q
  1. W !!,"This option produces a worksheet of (A) All Clinics, (C) Active, (D) Duplicate, ",!,"(I) Inactive, "
  1. W "or only the (U) Unreviewed Clinics that are awaiting approval."
  1. ;W !!,"Clinics that were defined as ""inactive"" by MAS/HAS the last time the"
  1. ;W !,"option ""Create DSS Clinic Stop Code File"" was run will be indicated with",!,"an ""*"".",!
  1. ;190 - Remove all other print options; report is now Export only
  1. ;W !!,"Choose (X) for exporting the CLINICS AND STOP CODES FILE to a text file for"
  1. ;W !,"spreadsheet use.",!
  1. 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
  1. W !,"If the most recent clinic changes from the HOSPITAL LOCATION file #44",!,"are desired, run the CREATE option before running a report.**",! ;144
  1. ;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
  1. ;S DIR("?",1)="Enter: ""C"" to print a worksheet of all active DSS Clinic Stops,"
  1. ;S DIR("?",2)="Enter: ""I"" to print a worksheet of all inactive DSS Clinic Stops,"
  1. ;S DIR("?",3)="Enter: ""A"" to print a worksheet of all DSS Clinic Stops,"
  1. ;S DIR("?",4)="Enter: ""U"" to print only the Clinic Stops that have not been approved."
  1. ;S DIR("?",5)="Enter: ""D"" to print the Duplicate Clinics found." ;149
  1. ;S DIR("?")="Enter: ""X"" to export CLINICS AND STOP CODES FILE to a text file."
  1. ;D ^DIR K DIR G ENDX:$D(DIRUT) S ECALL=$E(Y)
  1. S ECALL="X" D EXPORT^ECXSCLD1 Q ;190 - Set ECALL to "X" to make sure we don't break anythign else
  1. ;I ECALL'="D" W !!,"**REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY**",! ;161
  1. ;S %ZIS="Q" D ^%ZIS Q:POP
  1. ;I $D(IO("Q")) K ZTSAVE S ZTDESC="DSS clinic stop code work sheet",ZTRTN="SPRINT^ECXSCLD",ZTSAVE("ECALL")="" D ^%ZTLOAD,HOME^%ZIS Q
  1. SPRINT ; queued entry to print work sheet
  1. N DC,ECSDC,DIV1,DIV2,APPL,APPL1,APPL2,STOPC,CREDSC,NATC,DUPIEN,FIEN,ECSC,ECSCI,ECSC2 ;149
  1. N ECSTA6A ;184
  1. U IO
  1. S QFLG=0,$P(LN,"-",$S(ECALL="D":80,1:132))="",PG=0 ;161
  1. S ECDATE=$O(^ECX(728.44,"A1","")) I ECDATE S ECDATE=-ECDATE,ECDATE=$$FMTE^XLFDT(ECDATE,"5DF"),ECDATE=$TR(ECDATE," ","0")
  1. K ^TMP("EC",$J) ;144
  1. I ECALL'="D" D
  1. .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
  1. ..I $P($G(^SC(J,0)),U,3)'="C" Q ;144 Don't include entries that aren't clinic types
  1. ..I ECALL="A" I $D(^SC(J,0)) S ECSC=$P(^SC(J,0),U),^TMP("EC",$J,ECSC)=$P(ECSD,U,2,200)
  1. ..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)
  1. ..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)
  1. ..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
  1. .D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! Q ;144
  1. .I ECALL'="D" D ;149
  1. ..F J=1:1 S ECSC=$O(^TMP("EC",$J,ECSC)) Q:ECSC="" S ECD=^TMP("EC",$J,ECSC) D SHOWEM Q:QFLG ;149
  1. I ECALL="D" D
  1. .S FIRST=1
  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
  1. ..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
  1. ..I $D(^SC(DC,0)) D
  1. ...S STOPC=$P(ECSDC,U,2),CREDSC=$P(ECSDC,U,3),NATC=$P(ECSDC,U,8) ;154 CVW
  1. ...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
  1. ...S ECSTA6A=$$GET1^DIQ(4,$P(ECSDC,U,15),99,"E") ;184
  1. ...I 'FIRST D
  1. ....I $D(^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA)) D ;166
  1. .....S ^TMP("EC",$J,1_STOPC_CREDSC_NATC_DIV_APPL_ECXMCA,0)="1" ;166
  1. ...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
  1. ..I FIRST D
  1. ...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
  1. .D HEAD S ECSC="" I $O(^TMP("EC",$J,ECSC))="" W !!,"NO DATA FOUND FOR WORKSHEET.",! Q ;144
  1. I ECALL="D" D
  1. .S KEY="" F S KEY=$O(^TMP("EC",$J,KEY)) Q:'+KEY I $G(^TMP("EC",$J,KEY,0)) Q:QFLG D
  1. ..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
  1. ...I $Y+6>IOSL D HEAD Q:QFLG
  1. ...S ECXCLX=^TMP("EC",$J,KEY,IEN,NAME) ;166
  1. ...W !,$P(ECXCLX,U) ;161,166
  1. ...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
  1. ...W ?67,$P(^TMP("EC",$J,KEY,IEN,NAME),U,7),?76,$P(^TMP("EC",$J,KEY,IEN,NAME),U,8) ;161,166
  1. ...W ?82,$P(^TMP("EC",$J,KEY,IEN,NAME),U,9) ;184
  1. ..Q:QFLG W !
  1. ..I $Y+6>IOSL D HEAD Q:QFLG
  1. K ^TMP("EC",$J) ;144
  1. I $E(IOST)="C",'QFLG D SS^ECXSCLD1 ;161
  1. D ENDX ;161
  1. W:$Y @IOF D ^%ZISC S ZTREQ="@"
  1. Q
  1. D HEAD^ECXSCLD1
  1. Q
  1. ;
  1. SHOWEM ; list clinics for worksheet 149 moved to ECXSCLD1 due to size
  1. D SHOWEM^ECXSCLD1
  1. Q
  1. EDIT ; put in DSS stopcodes and which one to send
  1. ;184 - Edit clinic moved to ECXSCLD1 due to routine size
  1. D EDIT^ECXSCLD1 ;184
  1. Q
  1. ENDCHK ;check validity of clinic
  1. N ECXB4ARR,ECXAFARR,ECXCHNG ;154
  1. N ECXINST ;184
  1. S ECXCHNG=0 ;154
  1. ;154 REMOVED ALL ERROR CHECKING SINCE EDIT OF FIELDS REMOVED **EDIT1 code was moved to ECXSCLD1 for space
  1. ;S CODE=$P(^ECX(728.44,CLIEN1,0),U,4)
  1. ;K ERR,WRN,ECXERR,WARNING,ERRCHK
  1. ;S ERRCHK=0
  1. ;D STOP^ECXSTOP(CODE,"DSS Stop Code",CLIEN1) D ERRPRNT
  1. ;I $D(ECXERR) S ERRCHK=1
  1. ;K ERR,WRN,ECXERR,WARNING
  1. ;S CODE=$P(^ECX(728.44,CLIEN1,0),U,5)
  1. ;D STOP^ECXSTOP(CODE,"Credit Stop Code",CLIEN1) D ERRPRNT
  1. ;I $D(ECXERR) S ERRCHK=1
  1. ;W; !!,"...Validity Checker Complete."
  1. ;I ERRCHK=1 W !!,"...Errors found please fix." G EDIT1
  1. ;remaining fields
  1. ;D GETS^DIQ(728.44,CLIEN1,"5;7;8","I","ECXB4ARR")
  1. D GETS^DIQ(728.44,CLIEN1,"5;7;8;14","I","ECXB4ARR") ;184 - Added 14
  1. S DIE=728.44,DA=+CLIEN1,DIE("NO^")="BACKOUTOK" ;166 added restriction to only allow backward jumping or exit from template
  1. ;S DR="5//1;S:X'=4 Y=6;7CHAR4 CODE;6///"_DT_";8;10" D ^DIE ;136
  1. S DR="5//5;S:X'=4 Y=13;7CHAR4 CODE;13;8;10;14" D ^DIE ;154,161,166,184 - Added 14
  1. S:$P(^ECX(728.44,DA,0),U,6)'=4 $P(^ECX(728.44,CLIEN1,0),U,8)="" ;S $P(^(0),U,7)="" ;154
  1. 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
  1. D GETS^DIQ(728.44,CLIEN1,"5;7;8;14","I","ECXAFARR") ;154,184 - Added 14
  1. 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
  1. I ECXCHNG S $P(^ECX(728.44,CLIEN1,0),U,7)="" ;154
  1. Q
  1. ERRPRNT ;print errors 149 moved to ECXSCLD1 due to size
  1. D ERRPRNT^ECXSCLD1
  1. Q
  1. KILL ;
  1. K I,WARNING,DIC,DIE,DA,DR,DIR,DIRUT,DTOUT,DUOUT,X,Y,ERRCHK
  1. K CLIEN1,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT,ERR,WRN,ECXERR
  1. G EDIT^ECXSCLD1 ;184 - Moved EDIT to ECXSCLC1 due to routine size
  1. ;
  1. ERRCHK(CODE,TYPE,CLIEN1) ;check for problems 149 moved to ECXSCLD1 due to size
  1. Q $$ERRCHK^ECXSCLD1(CODE,TYPE,CLIEN1)
  1. ;
  1. APPROVE ; approve current DSS Stop and Credit Stop codes
  1. 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"
  1. W !,"from the list printed from the ""Clinic and DSS Stop Codes Print"" when you",!,"choose to print only ""unreviewed"" clinics.",!
  1. 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"
  1. S DIR("?",1)=" Enter:"
  1. S DIR("?",2)=" ""YES"" if you concur with the ""Clinic and DSS Stop Codes Print"","
  1. S DIR("?",3)=" ""NO"" or <RET> if you do not want to approve the current information,"
  1. S DIR("?")=" ""^"" to exit option."
  1. D ^DIR K DIR I 'Y!($D(DIRUT)) G ENDX
  1. W ! S ZTRTN="APPLOOP^ECXSCLD",ZTIO="",ZTDESC="Approve DSS stop codes for clinic extract" D ^%ZTLOAD W !!,"...approval queued" G ENDX
  1. ;
  1. APPLOOP ; queued entry to approve action codes
  1. 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
  1. S ZTREQ="@"
  1. K ^XTMP("ECX UNREVIEWED CLINICS") S ^XTMP("ECX UNREVIEWED CLINICS",0)=$$FMADD^XLFDT(DT,180)_U_DT_U_"ECX UNREVIEWED CLINICS"
  1. ENDX K X,Y,DA,DR,DIC,DIE,QFLG,PG,LN,ZTRTN,ZTIO,ZTDESC
  1. K DIR,DIRUT,DTOUT,DUOUT,CLIEN,CODE,ECXMSG,IENS,STOP,CSTOP,AMIS,FDA,OUT
  1. K J,ECSC,ECSD,ECDATE,ECD,ECN,ECNON,QFLG,PG,LN,SS,POP,%ZIS
  1. K EC,ECD,ECD2,ECL,ECS,ECS2,ECP,ECSC,ECSC2,ECDB,ECDNEW,ECDDIF,ECSCSIGN,ECDF,ECALL,ID,RD,KEY,IEN,FIRST,NAME ;161
  1. ;ECXINAC-patch 142 removed variable,it is no longer used
  1. Q
  1. ;
  1. PAUSE ;pause screen
  1. N DIR,X,Y,DTOUT,DUOUT,DIROUT,DIRUT
  1. S DIR(0)="E" W !! D ^DIR W !!
  1. Q
  1. ;
  1. LOOK ;queued entry to check for new clinics
  1. N DAT,ECD0,ECXMISS,ID,ECGRP
  1. S ECD=$E(DT,1,5)-1-($E(DT,4,5)="01"*8800),ECD0=ECD_"00",ECXMISS=10,ECGRP="SCX" K ^TMP("ECXS",$J)
  1. 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
  1. .S ID=+DAT,RD=$P(DAT,U,2) I ID,ID<DT I 'RD!(RD>DT) Q
  1. .S ^TMP("ECXS",$J,ECXMISS,0)=$J(EC,6)_" "_$$LJ^XLFSTR($P(^SC(EC,0),U),40),ECXMISS=ECXMISS+1
  1. D ^ECXSCX1
  1. Q