ECX3P120 ;ALB/JAP - DSS FY2010 Conversion, Post-init ; 6/18/09 9:51am
;;3.0;DSS EXTRACTS;**120**;Dec 22, 1997;Build 43
;
;****************************************
;Every year: Populate FY Year's version
; TESTON^ECXTREX(XPDNM,"FY2010")
;****************************************
;
POST ;post-init
D TEST,OPT
N ECXI
;add observation treating specialty
TS F ECXI=1:1 S ECXOTS=$P($T(OTSP+ECXI),";;",2) Q:ECXOTS="QUIT" D
.D OTS
Q
;
TEST ;turn-on fld #73 in file #728 for Field Test Site;
;allows use of option ECX FISCAL YEAR EXTRACT by test sites;
D MES^XPDUTL(" ")
D MES^XPDUTL("Providing special menu option access for DSS FY Conversion test sites.")
D TESTON^ECXTREX(XPDNM,"FY2010")
;D MES^XPDUTL(" ")
;D MES^XPDUTL("Remember to assign the ECX DSS TEST key to qualified users.")
D MES^XPDUTL(" ")
;if this is the national released version, then fld #73 will be turned-off
;the first time any user attempts to use ECX FISCAL YEAR EXTRACT option;
;
;initialize new field # in file #728.44;
N EC,ECD,X
S EC=0 F S EC=$O(^SC(EC)) Q:'EC D
.I $D(^SC(EC,0)) S ECD=^(0) I $P(ECD,U,3)="C" D
..S X=$P(ECD,U,17) I X'="" I $D(^ECX(728.44,EC,0)) S $P(^ECX(728.44,EC,0),U,12)=X
Q
OPT ;delete ECX LBB SOURCE AUDIT from ECX SOURCE AUDITS
;
D MES^XPDUTL("...Cleaning up ECX SOURCE AUDITS menu")
N DIC,Y
S DIC="^DIC(19,",DIC(0)="MBX",X="ECX SOURCE AUDITS" D ^DIC Q:+Y<0
S DA(1)=+Y
S DIC="^DIC(19,"_DA(1)_",10,",DIC(0)="MBX",X="ECX LBB SOURCE AUDIT" D ^DIC Q:+Y<0
S DA=+Y
S DIK="^DIC(19,"_DA(1)_",10," D ^DIK
Q
OTS ;Add Observation Treating Specialty to DSS TREATING SPECIALTY TRANSLATION File (#727.831)
D BMES^XPDUTL(">>>"_$P(ECXOTS,U,2)_">>>")
N DA,ECXFILE,DIC,DIE,DINUM,DLAYGO,DR,X,Y
S ECXERR=0
S DIC="^ECX(727.831,"
S DIC(0)="LX"
S DINUM=$P(ECXOTS,U)
S X=$P(ECXOTS,U,2)
S DLAYGO=727.831
D ^DIC
S ECXIFN=Y
I +ECXIFN=-1 D Q
.D MES^XPDUTL(" Entry not added to DSS TREATING SPECIALTY TRANSLATION File (#727.831). No further updating will occur.")
.D MES^XPDUTL(" Please contact Customer Service for assistance.")
.Q
I $P(ECXIFN,U,3)'=1&(+ECXIFN'=$P(ECXOTS,U)) D Q
.D MES^XPDUTL(" Entry exists in DSS TREATING SPECIALTY TRANSLATION File (#727.831), but with a different Treating Specialty.")
.D MES^XPDUTL(" No further updating will occur. Please review entry.")
.S ECXERR=1
.Q
D MES^XPDUTL(" Entry "_$S($P(ECXIFN,U,3)=1:"added to",1:"exists in")_" DSS TREATING SPECIALTY TRANSLATION File (#727.831).")
D MES^XPDUTL(" Updating DSS TREATING SPECIALTY TRANSLATION File fields.")
S DIE=DIC
S DR="4///"_$P(ECXOTS,U,3)_";5///"_$P(ECXOTS,U,4)_";6///"_$P(ECXOTS,U,5)
S DA=+ECXIFN
D ^DIE
Q
OTSP ;Treating Specialty #^Treating Specialty Name^Observation Pat Indicator^Inpat Outpat Code^Observation Stop Code
;;108^ED OBSERVATION^Y^O^297
;;QUIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P120 2890 printed Dec 13, 2024@01:50:08 Page 2
ECX3P120 ;ALB/JAP - DSS FY2010 Conversion, Post-init ; 6/18/09 9:51am
+1 ;;3.0;DSS EXTRACTS;**120**;Dec 22, 1997;Build 43
+2 ;
+3 ;****************************************
+4 ;Every year: Populate FY Year's version
+5 ; TESTON^ECXTREX(XPDNM,"FY2010")
+6 ;****************************************
+7 ;
POST ;post-init
+1 DO TEST
DO OPT
+2 NEW ECXI
+3 ;add observation treating specialty
TS FOR ECXI=1:1
SET ECXOTS=$PIECE($TEXT(OTSP+ECXI),";;",2)
if ECXOTS="QUIT"
QUIT
Begin DoDot:1
+1 DO OTS
End DoDot:1
+2 QUIT
+3 ;
TEST ;turn-on fld #73 in file #728 for Field Test Site;
+1 ;allows use of option ECX FISCAL YEAR EXTRACT by test sites;
+2 DO MES^XPDUTL(" ")
+3 DO MES^XPDUTL("Providing special menu option access for DSS FY Conversion test sites.")
+4 DO TESTON^ECXTREX(XPDNM,"FY2010")
+5 ;D MES^XPDUTL(" ")
+6 ;D MES^XPDUTL("Remember to assign the ECX DSS TEST key to qualified users.")
+7 DO MES^XPDUTL(" ")
+8 ;if this is the national released version, then fld #73 will be turned-off
+9 ;the first time any user attempts to use ECX FISCAL YEAR EXTRACT option;
+10 ;
+11 ;initialize new field # in file #728.44;
+12 NEW EC,ECD,X
+13 SET EC=0
FOR
SET EC=$ORDER(^SC(EC))
if 'EC
QUIT
Begin DoDot:1
+14 IF $DATA(^SC(EC,0))
SET ECD=^(0)
IF $PIECE(ECD,U,3)="C"
Begin DoDot:2
+15 SET X=$PIECE(ECD,U,17)
IF X'=""
IF $DATA(^ECX(728.44,EC,0))
SET $PIECE(^ECX(728.44,EC,0),U,12)=X
End DoDot:2
End DoDot:1
+16 QUIT
OPT ;delete ECX LBB SOURCE AUDIT from ECX SOURCE AUDITS
+1 ;
+2 DO MES^XPDUTL("...Cleaning up ECX SOURCE AUDITS menu")
+3 NEW DIC,Y
+4 SET DIC="^DIC(19,"
SET DIC(0)="MBX"
SET X="ECX SOURCE AUDITS"
DO ^DIC
if +Y<0
QUIT
+5 SET DA(1)=+Y
+6 SET DIC="^DIC(19,"_DA(1)_",10,"
SET DIC(0)="MBX"
SET X="ECX LBB SOURCE AUDIT"
DO ^DIC
if +Y<0
QUIT
+7 SET DA=+Y
+8 SET DIK="^DIC(19,"_DA(1)_",10,"
DO ^DIK
+9 QUIT
OTS ;Add Observation Treating Specialty to DSS TREATING SPECIALTY TRANSLATION File (#727.831)
+1 DO BMES^XPDUTL(">>>"_$PIECE(ECXOTS,U,2)_">>>")
+2 NEW DA,ECXFILE,DIC,DIE,DINUM,DLAYGO,DR,X,Y
+3 SET ECXERR=0
+4 SET DIC="^ECX(727.831,"
+5 SET DIC(0)="LX"
+6 SET DINUM=$PIECE(ECXOTS,U)
+7 SET X=$PIECE(ECXOTS,U,2)
+8 SET DLAYGO=727.831
+9 DO ^DIC
+10 SET ECXIFN=Y
+11 IF +ECXIFN=-1
Begin DoDot:1
+12 DO MES^XPDUTL(" Entry not added to DSS TREATING SPECIALTY TRANSLATION File (#727.831). No further updating will occur.")
+13 DO MES^XPDUTL(" Please contact Customer Service for assistance.")
+14 QUIT
End DoDot:1
QUIT
+15 IF $PIECE(ECXIFN,U,3)'=1&(+ECXIFN'=$PIECE(ECXOTS,U))
Begin DoDot:1
+16 DO MES^XPDUTL(" Entry exists in DSS TREATING SPECIALTY TRANSLATION File (#727.831), but with a different Treating Specialty.")
+17 DO MES^XPDUTL(" No further updating will occur. Please review entry.")
+18 SET ECXERR=1
+19 QUIT
End DoDot:1
QUIT
+20 DO MES^XPDUTL(" Entry "_$SELECT($PIECE(ECXIFN,U,3)=1:"added to",1:"exists in")_" DSS TREATING SPECIALTY TRANSLATION File (#727.831).")
+21 DO MES^XPDUTL(" Updating DSS TREATING SPECIALTY TRANSLATION File fields.")
+22 SET DIE=DIC
+23 SET DR="4///"_$PIECE(ECXOTS,U,3)_";5///"_$PIECE(ECXOTS,U,4)_";6///"_$PIECE(ECXOTS,U,5)
+24 SET DA=+ECXIFN
+25 DO ^DIE
+26 QUIT
OTSP ;Treating Specialty #^Treating Specialty Name^Observation Pat Indicator^Inpat Outpat Code^Observation Stop Code
+1 ;;108^ED OBSERVATION^Y^O^297
+2 ;;QUIT
+3 QUIT
