SDES893P ;ALB/JAS,MCB - SD*5.3*893 Post Init Routine ; OCT 04, 2024
;;5.3;SCHEDULING;**893**;AUG 13, 1993;Build 6
;;Per VHA Directive 6402, this routine should not be modified
;;
Q
;
EN ; Update the VS GUI version in #409.98
D WWIIUPDATE
D TASK
D TASK1
Q
;
TASK ;
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*893 Post-Install to populate new comments auditing multiples")
D MES^XPDUTL(" in the SDEC APPT REQUEST file (#409.85) and the SDEC APPOINTMENT file (#409.84)")
D MES^XPDUTL(" is being queued to run in the background.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*893 Post Install Routine"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="COMMCONV^SDES893P",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
. D MES^XPDUTL("")
I '$D(ZTSK) D
. D MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
. D MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
Q
;
TASK1 ;
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*893 Post-Install to populate VETERAN SELF-CANCEL on HOSPITAL LOCATION (#44)")
D MES^XPDUTL(" is being queued to run in the background.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*893 Post Install Routine"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="HLPOST^SDES893P",ZTSAVE("*")="" D ^%ZTLOAD
I $D(ZTSK) D
. D MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
. D MES^XPDUTL("")
I '$D(ZTSK) D
. D MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
. D MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
Q
;
COMMCONV ; Save Comments data into the new Comments mults
;
N APPTIEN,APREQIEN,COMMARRAY,COMMENTS,COMMIEN,FDA
S APREQIEN=0
F S APREQIEN=$O(^SDEC(409.85,APREQIEN)) Q:'APREQIEN I $D(^SDEC(409.85,APREQIEN,0)) D
. S COMMENTS=$$GET1^DIQ(409.85,APREQIEN,25,"E") I $L(COMMENTS) D
. . Q:$D(^SDEC(409.85,APREQIEN,"COMAUD"))
. . S FDA(409.8527,"+1,"_APREQIEN_",",.01)=$$GET1^DIQ(409.85,APREQIEN,9.5,"I")
. . S FDA(409.8527,"+1,"_APREQIEN_",",1)=$$GET1^DIQ(409.85,APREQIEN,9,"I")
. . S FDA(409.8527,"+1,"_APREQIEN_",",2)=COMMENTS
. . D UPDATE^DIE("","FDA") K FDA
;
S APPTIEN=0
F S APPTIEN=$O(^SDEC(409.84,APPTIEN)) Q:'APPTIEN I $D(^SDEC(409.84,APPTIEN,1)) D
. S COMMIEN=0
. K COMMARRAY
. F S COMMIEN=$O(^SDEC(409.84,APPTIEN,1,COMMIEN)) Q:'COMMIEN S COMMARRAY(COMMIEN)=^SDEC(409.84,APPTIEN,1,COMMIEN,0)
. I $D(COMMARRAY) D
. . Q:$D(^SDEC(409.84,APPTIEN,"NOTEAUD"))
. . S COMMENTS=$$WPSTR^SDECUTL(.COMMARRAY)
. . S FDA(409.847,"+1,"_APPTIEN_",",.01)=$$GET1^DIQ(409.84,APPTIEN,.09,"I")
. . S FDA(409.847,"+1,"_APPTIEN_",",1)=$$GET1^DIQ(409.84,APPTIEN,.08,"I")
. . S FDA(409.847,"+1,"_APPTIEN_",",2)=COMMENTS
. . D UPDATE^DIE("","FDA") K FDA
Q
;
WWIIUPDATE ; Update WORLD WAR II record in APPOINTMENT TYPE (#409.1) file
;
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*893 Post-Install has reset the IGNORE MEANS TEST BILLING (#2)")
D MES^XPDUTL(" field in the APPOINTMENT TYPE file (#409.1) for the WORLD WAR II entry ")
D MES^XPDUTL(" to prevent encounters from becoming non-billable. ")
D MES^XPDUTL("")
N APPTTYPEIEN,FDA
S APPTTYPEIEN=$O(^SD(409.1,"B","WORLD WAR II",0))
Q:APPTTYPEIEN=""
;
S FDA(409.1,APPTTYPEIEN_",",2)="@"
D FILE^DIE(,"FDA") K FDA
Q
;
HLPOST ; Update HOSPITAL LOCATION file (#44) field VETERAN SELF-CANCEL (#63)
N CIEN,NONCOUNT,FDA,PROHIBIT,VETCAN
S CIEN=0 F S CIEN=$O(^SC(CIEN)) Q:'CIEN D
.S NONCOUNT=$$GET1^DIQ(44,CIEN,2502,"I")
.S NONCOUNT=$S(NONCOUNT="Y":1,1:0)
.S PROHIBIT=$$GET1^DIQ(44,CIEN,2500,"I")
.S PROHIBIT=$S(PROHIBIT="Y":1,1:0)
.S VETCAN=$$GET1^DIQ(44,CIEN,63,"I") ; Check for existing value
.I NONCOUNT D Q
..;S FDA(44,CIEN_",",63)=$S(VETCAN'="":VETCAN,1:0) D FILE^DIE(,"FDA") K FDA
..S FDA(44,CIEN_",",63)=0 D FILE^DIE(,"FDA") K FDA
.I 'PROHIBIT D Q
..;S FDA(44,CIEN_",",63)=$S(VETCAN'="":VETCAN,1:1) D FILE^DIE(,"FDA") K FDA
..S FDA(44,CIEN_",",63)=1 D FILE^DIE(,"FDA") K FDA
.I PROHIBIT D
..;S FDA(44,CIEN_",",63)=$S(VETCAN'="":VETCAN,1:$$PROXY(CIEN)) D FILE^DIE(,"FDA") K FDA
..S FDA(44,CIEN_",",63)=$$PROXY(CIEN) D FILE^DIE(,"FDA") K FDA
Q
PROXY(CLINIEN) ;
N SPROX,VPROX,PFLAG
S SPROX=$O(^VA(200,"B","SDESOITEAS,SRV",0))
S VPROX=$O(^VA(200,"B","VIABAPPLICATIONPROXY,VIAB",0))
S PFLAG=0
I SPROX,$D(^SC(CLINIEN,"SDPRIV",SPROX)) S PFLAG=1
I VPROX,$D(^SC(CLINIEN,"SDPRIV",VPROX)) S PFLAG=1
Q PFLAG
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES893P 4481 printed Dec 13, 2024@02:55:33 Page 2
SDES893P ;ALB/JAS,MCB - SD*5.3*893 Post Init Routine ; OCT 04, 2024
+1 ;;5.3;SCHEDULING;**893**;AUG 13, 1993;Build 6
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;;
+4 QUIT
+5 ;
EN ; Update the VS GUI version in #409.98
+1 DO WWIIUPDATE
+2 DO TASK
+3 DO TASK1
+4 QUIT
+5 ;
TASK ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*893 Post-Install to populate new comments auditing multiples")
+3 DO MES^XPDUTL(" in the SDEC APPT REQUEST file (#409.85) and the SDEC APPOINTMENT file (#409.84)")
+4 DO MES^XPDUTL(" is being queued to run in the background.")
+5 DO MES^XPDUTL("")
+6 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+7 SET ZTDESC="SD*5.3*893 Post Install Routine"
+8 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="COMMCONV^SDES893P"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
Begin DoDot:1
+10 DO MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
+11 DO MES^XPDUTL("")
End DoDot:1
+12 IF '$DATA(ZTSK)
Begin DoDot:1
+13 DO MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
+14 DO MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
End DoDot:1
+15 QUIT
+16 ;
TASK1 ;
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*893 Post-Install to populate VETERAN SELF-CANCEL on HOSPITAL LOCATION (#44)")
+3 DO MES^XPDUTL(" is being queued to run in the background.")
+4 DO MES^XPDUTL("")
+5 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+6 SET ZTDESC="SD*5.3*893 Post Install Routine"
+7 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="HLPOST^SDES893P"
SET ZTSAVE("*")=""
DO ^%ZTLOAD
+8 IF $DATA(ZTSK)
Begin DoDot:1
+9 DO MES^XPDUTL(" >>>Task "_ZTSK_" has been queued.")
+10 DO MES^XPDUTL("")
End DoDot:1
+11 IF '$DATA(ZTSK)
Begin DoDot:1
+12 DO MES^XPDUTL(" UNABLE TO QUEUE THIS JOB.")
+13 DO MES^XPDUTL(" Please contact the National Help Desk to report this issue.")
End DoDot:1
+14 QUIT
+15 ;
COMMCONV ; Save Comments data into the new Comments mults
+1 ;
+2 NEW APPTIEN,APREQIEN,COMMARRAY,COMMENTS,COMMIEN,FDA
+3 SET APREQIEN=0
+4 FOR
SET APREQIEN=$ORDER(^SDEC(409.85,APREQIEN))
if 'APREQIEN
QUIT
IF $DATA(^SDEC(409.85,APREQIEN,0))
Begin DoDot:1
+5 SET COMMENTS=$$GET1^DIQ(409.85,APREQIEN,25,"E")
IF $LENGTH(COMMENTS)
Begin DoDot:2
+6 if $DATA(^SDEC(409.85,APREQIEN,"COMAUD"))
QUIT
+7 SET FDA(409.8527,"+1,"_APREQIEN_",",.01)=$$GET1^DIQ(409.85,APREQIEN,9.5,"I")
+8 SET FDA(409.8527,"+1,"_APREQIEN_",",1)=$$GET1^DIQ(409.85,APREQIEN,9,"I")
+9 SET FDA(409.8527,"+1,"_APREQIEN_",",2)=COMMENTS
+10 DO UPDATE^DIE("","FDA")
KILL FDA
End DoDot:2
End DoDot:1
+11 ;
+12 SET APPTIEN=0
+13 FOR
SET APPTIEN=$ORDER(^SDEC(409.84,APPTIEN))
if 'APPTIEN
QUIT
IF $DATA(^SDEC(409.84,APPTIEN,1))
Begin DoDot:1
+14 SET COMMIEN=0
+15 KILL COMMARRAY
+16 FOR
SET COMMIEN=$ORDER(^SDEC(409.84,APPTIEN,1,COMMIEN))
if 'COMMIEN
QUIT
SET COMMARRAY(COMMIEN)=^SDEC(409.84,APPTIEN,1,COMMIEN,0)
+17 IF $DATA(COMMARRAY)
Begin DoDot:2
+18 if $DATA(^SDEC(409.84,APPTIEN,"NOTEAUD"))
QUIT
+19 SET COMMENTS=$$WPSTR^SDECUTL(.COMMARRAY)
+20 SET FDA(409.847,"+1,"_APPTIEN_",",.01)=$$GET1^DIQ(409.84,APPTIEN,.09,"I")
+21 SET FDA(409.847,"+1,"_APPTIEN_",",1)=$$GET1^DIQ(409.84,APPTIEN,.08,"I")
+22 SET FDA(409.847,"+1,"_APPTIEN_",",2)=COMMENTS
+23 DO UPDATE^DIE("","FDA")
KILL FDA
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
WWIIUPDATE ; Update WORLD WAR II record in APPOINTMENT TYPE (#409.1) file
+1 ;
+2 DO MES^XPDUTL("")
+3 DO MES^XPDUTL(" SD*5.3*893 Post-Install has reset the IGNORE MEANS TEST BILLING (#2)")
+4 DO MES^XPDUTL(" field in the APPOINTMENT TYPE file (#409.1) for the WORLD WAR II entry ")
+5 DO MES^XPDUTL(" to prevent encounters from becoming non-billable. ")
+6 DO MES^XPDUTL("")
+7 NEW APPTTYPEIEN,FDA
+8 SET APPTTYPEIEN=$ORDER(^SD(409.1,"B","WORLD WAR II",0))
+9 if APPTTYPEIEN=""
QUIT
+10 ;
+11 SET FDA(409.1,APPTTYPEIEN_",",2)="@"
+12 DO FILE^DIE(,"FDA")
KILL FDA
+13 QUIT
+14 ;
HLPOST ; Update HOSPITAL LOCATION file (#44) field VETERAN SELF-CANCEL (#63)
+1 NEW CIEN,NONCOUNT,FDA,PROHIBIT,VETCAN
+2 SET CIEN=0
FOR
SET CIEN=$ORDER(^SC(CIEN))
if 'CIEN
QUIT
Begin DoDot:1
+3 SET NONCOUNT=$$GET1^DIQ(44,CIEN,2502,"I")
+4 SET NONCOUNT=$SELECT(NONCOUNT="Y":1,1:0)
+5 SET PROHIBIT=$$GET1^DIQ(44,CIEN,2500,"I")
+6 SET PROHIBIT=$SELECT(PROHIBIT="Y":1,1:0)
+7 ; Check for existing value
SET VETCAN=$$GET1^DIQ(44,CIEN,63,"I")
+8 IF NONCOUNT
Begin DoDot:2
+9 ;S FDA(44,CIEN_",",63)=$S(VETCAN'="":VETCAN,1:0) D FILE^DIE(,"FDA") K FDA
+10 SET FDA(44,CIEN_",",63)=0
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
QUIT
+11 IF 'PROHIBIT
Begin DoDot:2
+12 ;S FDA(44,CIEN_",",63)=$S(VETCAN'="":VETCAN,1:1) D FILE^DIE(,"FDA") K FDA
+13 SET FDA(44,CIEN_",",63)=1
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
QUIT
+14 IF PROHIBIT
Begin DoDot:2
+15 ;S FDA(44,CIEN_",",63)=$S(VETCAN'="":VETCAN,1:$$PROXY(CIEN)) D FILE^DIE(,"FDA") K FDA
+16 SET FDA(44,CIEN_",",63)=$$PROXY(CIEN)
DO FILE^DIE(,"FDA")
KILL FDA
End DoDot:2
End DoDot:1
+17 QUIT
PROXY(CLINIEN) ;
+1 NEW SPROX,VPROX,PFLAG
+2 SET SPROX=$ORDER(^VA(200,"B","SDESOITEAS,SRV",0))
+3 SET VPROX=$ORDER(^VA(200,"B","VIABAPPLICATIONPROXY,VIAB",0))
+4 SET PFLAG=0
+5 IF SPROX
IF $DATA(^SC(CLINIEN,"SDPRIV",SPROX))
SET PFLAG=1
+6 IF VPROX
IF $DATA(^SC(CLINIEN,"SDPRIV",VPROX))
SET PFLAG=1
+7 QUIT PFLAG
+8 ;
