SDES907P ;ALB/JHV,JDJ,JAS - SD*5.3*907 Post Init Routine ; MAY 9, 2025
;;5.3;SCHEDULING;**907**;AUG 13, 1993;Build 5
;;Per VHA Directive 6402, this routine should not be modified
;
; Reference to NEW PERSON (200), KEY (200.051) in ICR #7054
; Reference to SECURITY KEY (19.1) in ICR #505
;
Q
;
EN ;
D TASK
D SDECSET
D TASK1,TASK2,TASK3
Q
;
SDECSET ; Update SDEC Help link text to that ISS reflects preferens set from IVC
N NATIEN,SUBIEN,FDA,FDAERR
S NATIEN=$O(^SDEC(409.98,"B","VS GUI NATIONAL",0))
S SUBIEN=$O(^SDEC(409.98,NATIEN,1,"B","Veterans Crisis Line - (800) 2",0)) Q:'SUBIEN
S FDA(409.981,SUBIEN_","_NATIEN_",",.01)="Veterans Crisis Line - 988 x1"
D FILE^DIE(,"FDA","FDAERR") K FDA
Q
TASK ; tasks off process to remove null comment audit entries from Recall Reminders file
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*907 Post-Install to disposition open MTRC Parent nodes")
D MES^XPDUTL("when all child nodes have appointments scheduled.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*907 Post Install Routine Task 1"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="VSE9701^SDES907P",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
;
VSE9701 ;disposition open parent MTRC requests when all child requests have appointments scheduled
N SDCONTEXT,SDINPUT
K ^XTMP("SDES907P","VSE-9701")
D FIXMRTC(.SDCONTEXT,.SDINPUT)
D MAIL
Q
;
FIXMRTC(SDCONTEXT,SDINPUT) ;
N RECCNT,APPTIEN,NODENUM,APPT,CREATEDT,PARENTIEN,CREATEDTTX,NUMMRTC,MRTCAPPT,CHILDIEN,FOUND,DISP,CHILDCNT
S RECCNT=0
S ^XTMP("SDES907P","VSE-9701",1)="REQUEST IEN;CREATED DT"
S NODENUM=1
S CREATEDT=0
F S CREATEDT=$O(^SDEC(409.85,"E","O",CREATEDT)) Q:'CREATEDT D
. S CREATEDTTX=$P($$FMTISO^SDAMUTDT(CREATEDT),"-",1,3)
. S PARENTIEN=0 F S PARENTIEN=$O(^SDEC(409.85,"E","O",CREATEDT,PARENTIEN)) Q:'PARENTIEN D
.. I $$GET1^DIQ(409.85,PARENTIEN,41,"I")'=1 Q ;Req is MRTC
.. I $$GET1^DIQ(409.85,PARENTIEN,43.8,"I")'="" Q ;Req is parent req
.. S CHILDIEN="",FOUND=0,CHILDCNT=0
.. F S CHILDIEN=$O(^SDEC(409.85,PARENTIEN,2,"B",CHILDIEN)) Q:(CHILDIEN="")!(FOUND) D
... S CHILDCNT=CHILDCNT+1
... S DISP=$$GET1^DIQ(409.85,CHILDIEN_",",23,"E")
... I DISP="OPEN" S FOUND=1
.. I 'FOUND,CHILDCNT'=0 D
... S FDA(409.85,PARENTIEN_",",20)=.5
... S FDA(409.85,PARENTIEN_",",21)=$$FIND1^DIC(409.853,,"B","MRTC PARENT CLOSED")
... S FDA(409.85,PARENTIEN_",",23)="C"
... S FDA(409.85,PARENTIEN_",",19)=$P($$NOW^XLFDT,".",1)
... D FILE^DIE(,"FDA","ERROR") K FDA
... S NODENUM=NODENUM+1,RECCNT=RECCNT+1
... S ^XTMP("SDES907P","VSE-9701",NODENUM)=PARENTIEN_";"_CREATEDTTX
S NODENUM=NODENUM+1
S ^XTMP("SDES907P","VSE-9701",NODENUM)="TOTAL NUMBER RECORDS IMPACTED: "_RECCNT
Q
;
MAIL ;
N STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM,%,D,D0,D1,D2,DG,DIC,DICR,DIW,XMDUN,XMZ
S STANUM=$$KSP^XUPARAM("INST")_","
S STANUM=$$GET1^DIQ(4,STANUM,99)
S MESS1="Station: "_STANUM_" - "
S XMDUZ=DUZ
S XMTEXT="^XTMP(""SDES907P"",""VSE-9701"","
S XMSUB=MESS1_"SD*5.3*907 - Post Install Data Report VSE-9701"
S XMDUZ=.5,XMY(DUZ)="",XMY(XMDUZ)=""
S XMY("BARBER.LORI@DOMAIN.EXT")=""
S XMY("DUNNAM.DAVID@DOMAIN.EXT")=""
S XMY("VARNO.JOSEPH@DOMAIN.EXT")=""
D ^XMD
K ^XTMP("SDES907P","VSE-9701")
Q
;
TASK1 ; tasks off process to remove null comment audit entries from Recall Reminders file
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*907 Post-Install to remove null entries from the COMMENT")
D MES^XPDUTL(" AUDIT (#403.57) sub-file is being queued to run in the background.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*907 Post Install Routine Task 1"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="CLNRECREMS^SDES907P",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
;
CLNRECREMS ;
;
N RECREQIEN,COMAUDIEN,COMMENT,COMMENTS,FDA
S RECREQIEN=0
F S RECREQIEN=$O(^SD(403.5,RECREQIEN)) Q:'RECREQIEN I $D(^SD(403.5,RECREQIEN,2)) D
. S COMAUDIEN=0
. F S COMAUDIEN=$O(^SD(403.5,RECREQIEN,2,COMAUDIEN)) Q:'COMAUDIEN D
. . Q:'$D(^SD(403.5,RECREQIEN,2,COMAUDIEN,0))
. . S COMMENT=$$GET1^DIQ(403.57,COMAUDIEN_","_RECREQIEN_",",2)
. . I COMMENT="" D
. . . S FDA(403.57,COMAUDIEN_","_RECREQIEN_",",.01)="@"
. . . D FILE^DIE("","FDA") K FDA
Q
;
TASK2 ; tasks off process to remove null comment audit entries from SDEC Appt Request file
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*907 Post-Install to remove null entries from the COMMENTS")
D MES^XPDUTL(" AUDIT (#409.8527) sub-file is being queued to run in the background.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*907 Post Install Routine Task 2"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="CLNAPREQS^SDES907P",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
;
CLNAPREQS ;
;
N APREQIEN,COMAUDIEN,COMMENT,COMMENTS,FDA
S APREQIEN=0
F S APREQIEN=$O(^SDEC(409.85,APREQIEN)) Q:'APREQIEN I $D(^SDEC(409.85,APREQIEN,"COMAUD")) D
. S COMAUDIEN=0
. F S COMAUDIEN=$O(^SDEC(409.85,APREQIEN,"COMAUD",COMAUDIEN)) Q:'COMAUDIEN D
. . S COMMENT=$$GET1^DIQ(409.8527,COMAUDIEN_","_APREQIEN_",",2)
. . I COMMENT="" D
. . . S FDA(409.8527,COMAUDIEN_","_APREQIEN_",",.01)="@"
. . . D FILE^DIE("","FDA") K FDA
Q
;
TASK3 ; tasks off process to remove null note audit entries from SDEC Appointment file
D MES^XPDUTL("")
D MES^XPDUTL(" SD*5.3*907 Post-Install to remove null entries from the NOTE")
D MES^XPDUTL(" AUDIT (#409.847) sub-file is being queued to run in the background.")
D MES^XPDUTL("")
N ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
S ZTDESC="SD*5.3*907 Post Install Routine Task 3"
D NOW^%DTC S ZTDTH=X,ZTIO="",ZTRTN="CLNAPPTS^SDES907P",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
;
CLNAPPTS ;
;
N APPTIEN,APREQIEN,COMAUDIEN,COMMARRAY,COMMENT,COMMENTS,COMMIEN,DATEIEN,EDITEDNOTE,FDA,REQREC
S DATEIEN=3231130.999999
F S DATEIEN=$O(^SDEC(409.84,"B",DATEIEN)) Q:'DATEIEN D
. S APPTIEN=0
. F S APPTIEN=$O(^SDEC(409.84,"B",DATEIEN,APPTIEN)) Q:'APPTIEN I $D(^SDEC(409.84,APPTIEN,"NOTEAUD")) D
. . S COMAUDIEN=0
. . F S COMAUDIEN=$O(^SDEC(409.84,APPTIEN,"NOTEAUD",COMAUDIEN)) Q:'COMAUDIEN D
. . . S COMMENT=$$GET1^DIQ(409.847,COMAUDIEN_","_APPTIEN_",",2)
. . . I COMMENT="" D
. . . . S FDA(409.847,COMAUDIEN_","_APPTIEN_",",.01)="@"
. . . . D UPDATE^DIE("","FDA") K FDA
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES907P 7232 printed Aug 26, 2025@23:12:02 Page 2
SDES907P ;ALB/JHV,JDJ,JAS - SD*5.3*907 Post Init Routine ; MAY 9, 2025
+1 ;;5.3;SCHEDULING;**907**;AUG 13, 1993;Build 5
+2 ;;Per VHA Directive 6402, this routine should not be modified
+3 ;
+4 ; Reference to NEW PERSON (200), KEY (200.051) in ICR #7054
+5 ; Reference to SECURITY KEY (19.1) in ICR #505
+6 ;
+7 QUIT
+8 ;
EN ;
+1 DO TASK
+2 DO SDECSET
+3 DO TASK1
DO TASK2
DO TASK3
+4 QUIT
+5 ;
SDECSET ; Update SDEC Help link text to that ISS reflects preferens set from IVC
+1 NEW NATIEN,SUBIEN,FDA,FDAERR
+2 SET NATIEN=$ORDER(^SDEC(409.98,"B","VS GUI NATIONAL",0))
+3 SET SUBIEN=$ORDER(^SDEC(409.98,NATIEN,1,"B","Veterans Crisis Line - (800) 2",0))
if 'SUBIEN
QUIT
+4 SET FDA(409.981,SUBIEN_","_NATIEN_",",.01)="Veterans Crisis Line - 988 x1"
+5 DO FILE^DIE(,"FDA","FDAERR")
KILL FDA
+6 QUIT
TASK ; tasks off process to remove null comment audit entries from Recall Reminders file
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*907 Post-Install to disposition open MTRC Parent nodes")
+3 DO MES^XPDUTL("when all child nodes have appointments scheduled.")
+4 DO MES^XPDUTL("")
+5 NEW ZTDESC,ZTRTN,ZTIO,ZTSK,X,ZTDTH,ZTSAVE
+6 SET ZTDESC="SD*5.3*907 Post Install Routine Task 1"
+7 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="VSE9701^SDES907P"
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 ;
VSE9701 ;disposition open parent MTRC requests when all child requests have appointments scheduled
+1 NEW SDCONTEXT,SDINPUT
+2 KILL ^XTMP("SDES907P","VSE-9701")
+3 DO FIXMRTC(.SDCONTEXT,.SDINPUT)
+4 DO MAIL
+5 QUIT
+6 ;
FIXMRTC(SDCONTEXT,SDINPUT) ;
+1 NEW RECCNT,APPTIEN,NODENUM,APPT,CREATEDT,PARENTIEN,CREATEDTTX,NUMMRTC,MRTCAPPT,CHILDIEN,FOUND,DISP,CHILDCNT
+2 SET RECCNT=0
+3 SET ^XTMP("SDES907P","VSE-9701",1)="REQUEST IEN;CREATED DT"
+4 SET NODENUM=1
+5 SET CREATEDT=0
+6 FOR
SET CREATEDT=$ORDER(^SDEC(409.85,"E","O",CREATEDT))
if 'CREATEDT
QUIT
Begin DoDot:1
+7 SET CREATEDTTX=$PIECE($$FMTISO^SDAMUTDT(CREATEDT),"-",1,3)
+8 SET PARENTIEN=0
FOR
SET PARENTIEN=$ORDER(^SDEC(409.85,"E","O",CREATEDT,PARENTIEN))
if 'PARENTIEN
QUIT
Begin DoDot:2
+9 ;Req is MRTC
IF $$GET1^DIQ(409.85,PARENTIEN,41,"I")'=1
QUIT
+10 ;Req is parent req
IF $$GET1^DIQ(409.85,PARENTIEN,43.8,"I")'=""
QUIT
+11 SET CHILDIEN=""
SET FOUND=0
SET CHILDCNT=0
+12 FOR
SET CHILDIEN=$ORDER(^SDEC(409.85,PARENTIEN,2,"B",CHILDIEN))
if (CHILDIEN="")!(FOUND)
QUIT
Begin DoDot:3
+13 SET CHILDCNT=CHILDCNT+1
+14 SET DISP=$$GET1^DIQ(409.85,CHILDIEN_",",23,"E")
+15 IF DISP="OPEN"
SET FOUND=1
End DoDot:3
+16 IF 'FOUND
IF CHILDCNT'=0
Begin DoDot:3
+17 SET FDA(409.85,PARENTIEN_",",20)=.5
+18 SET FDA(409.85,PARENTIEN_",",21)=$$FIND1^DIC(409.853,,"B","MRTC PARENT CLOSED")
+19 SET FDA(409.85,PARENTIEN_",",23)="C"
+20 SET FDA(409.85,PARENTIEN_",",19)=$PIECE($$NOW^XLFDT,".",1)
+21 DO FILE^DIE(,"FDA","ERROR")
KILL FDA
+22 SET NODENUM=NODENUM+1
SET RECCNT=RECCNT+1
+23 SET ^XTMP("SDES907P","VSE-9701",NODENUM)=PARENTIEN_";"_CREATEDTTX
End DoDot:3
End DoDot:2
End DoDot:1
+24 SET NODENUM=NODENUM+1
+25 SET ^XTMP("SDES907P","VSE-9701",NODENUM)="TOTAL NUMBER RECORDS IMPACTED: "_RECCNT
+26 QUIT
+27 ;
MAIL ;
+1 NEW STANUM,MESS1,XMTEXT,XMSUB,XMY,XMDUZ,DIFROM,%,D,D0,D1,D2,DG,DIC,DICR,DIW,XMDUN,XMZ
+2 SET STANUM=$$KSP^XUPARAM("INST")_","
+3 SET STANUM=$$GET1^DIQ(4,STANUM,99)
+4 SET MESS1="Station: "_STANUM_" - "
+5 SET XMDUZ=DUZ
+6 SET XMTEXT="^XTMP(""SDES907P"",""VSE-9701"","
+7 SET XMSUB=MESS1_"SD*5.3*907 - Post Install Data Report VSE-9701"
+8 SET XMDUZ=.5
SET XMY(DUZ)=""
SET XMY(XMDUZ)=""
+9 SET XMY("BARBER.LORI@DOMAIN.EXT")=""
+10 SET XMY("DUNNAM.DAVID@DOMAIN.EXT")=""
+11 SET XMY("VARNO.JOSEPH@DOMAIN.EXT")=""
+12 DO ^XMD
+13 KILL ^XTMP("SDES907P","VSE-9701")
+14 QUIT
+15 ;
TASK1 ; tasks off process to remove null comment audit entries from Recall Reminders file
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*907 Post-Install to remove null entries from the COMMENT")
+3 DO MES^XPDUTL(" AUDIT (#403.57) sub-file 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*907 Post Install Routine Task 1"
+7 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="CLNRECREMS^SDES907P"
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 ;
CLNRECREMS ;
+1 ;
+2 NEW RECREQIEN,COMAUDIEN,COMMENT,COMMENTS,FDA
+3 SET RECREQIEN=0
+4 FOR
SET RECREQIEN=$ORDER(^SD(403.5,RECREQIEN))
if 'RECREQIEN
QUIT
IF $DATA(^SD(403.5,RECREQIEN,2))
Begin DoDot:1
+5 SET COMAUDIEN=0
+6 FOR
SET COMAUDIEN=$ORDER(^SD(403.5,RECREQIEN,2,COMAUDIEN))
if 'COMAUDIEN
QUIT
Begin DoDot:2
+7 if '$DATA(^SD(403.5,RECREQIEN,2,COMAUDIEN,0))
QUIT
+8 SET COMMENT=$$GET1^DIQ(403.57,COMAUDIEN_","_RECREQIEN_",",2)
+9 IF COMMENT=""
Begin DoDot:3
+10 SET FDA(403.57,COMAUDIEN_","_RECREQIEN_",",.01)="@"
+11 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
TASK2 ; tasks off process to remove null comment audit entries from SDEC Appt Request file
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*907 Post-Install to remove null entries from the COMMENTS")
+3 DO MES^XPDUTL(" AUDIT (#409.8527) sub-file 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*907 Post Install Routine Task 2"
+7 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="CLNAPREQS^SDES907P"
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 ;
CLNAPREQS ;
+1 ;
+2 NEW APREQIEN,COMAUDIEN,COMMENT,COMMENTS,FDA
+3 SET APREQIEN=0
+4 FOR
SET APREQIEN=$ORDER(^SDEC(409.85,APREQIEN))
if 'APREQIEN
QUIT
IF $DATA(^SDEC(409.85,APREQIEN,"COMAUD"))
Begin DoDot:1
+5 SET COMAUDIEN=0
+6 FOR
SET COMAUDIEN=$ORDER(^SDEC(409.85,APREQIEN,"COMAUD",COMAUDIEN))
if 'COMAUDIEN
QUIT
Begin DoDot:2
+7 SET COMMENT=$$GET1^DIQ(409.8527,COMAUDIEN_","_APREQIEN_",",2)
+8 IF COMMENT=""
Begin DoDot:3
+9 SET FDA(409.8527,COMAUDIEN_","_APREQIEN_",",.01)="@"
+10 DO FILE^DIE("","FDA")
KILL FDA
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
TASK3 ; tasks off process to remove null note audit entries from SDEC Appointment file
+1 DO MES^XPDUTL("")
+2 DO MES^XPDUTL(" SD*5.3*907 Post-Install to remove null entries from the NOTE")
+3 DO MES^XPDUTL(" AUDIT (#409.847) sub-file 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*907 Post Install Routine Task 3"
+7 DO NOW^%DTC
SET ZTDTH=X
SET ZTIO=""
SET ZTRTN="CLNAPPTS^SDES907P"
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 ;
CLNAPPTS ;
+1 ;
+2 NEW APPTIEN,APREQIEN,COMAUDIEN,COMMARRAY,COMMENT,COMMENTS,COMMIEN,DATEIEN,EDITEDNOTE,FDA,REQREC
+3 SET DATEIEN=3231130.999999
+4 FOR
SET DATEIEN=$ORDER(^SDEC(409.84,"B",DATEIEN))
if 'DATEIEN
QUIT
Begin DoDot:1
+5 SET APPTIEN=0
+6 FOR
SET APPTIEN=$ORDER(^SDEC(409.84,"B",DATEIEN,APPTIEN))
if 'APPTIEN
QUIT
IF $DATA(^SDEC(409.84,APPTIEN,"NOTEAUD"))
Begin DoDot:2
+7 SET COMAUDIEN=0
+8 FOR
SET COMAUDIEN=$ORDER(^SDEC(409.84,APPTIEN,"NOTEAUD",COMAUDIEN))
if 'COMAUDIEN
QUIT
Begin DoDot:3
+9 SET COMMENT=$$GET1^DIQ(409.847,COMAUDIEN_","_APPTIEN_",",2)
+10 IF COMMENT=""
Begin DoDot:4
+11 SET FDA(409.847,COMAUDIEN_","_APPTIEN_",",.01)="@"
+12 DO UPDATE^DIE("","FDA")
KILL FDA
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
