SDAMLD ;ALB/CAW - Ambulartory Status Update Log Utilities ; 3/6/92
;;5.3;Scheduling;;Aug 13, 1993
;
EN D DT^DICRW S X=$T(+1),DIK="^DOPT("""_$P(X," ;",1)_""","
G:$D(^DOPT($P(X," ;"),4)) A S ^DOPT($P(X," ;"),0)=$P(X,";",3)_"^1N^" F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT($P(X," ;"),I,0)=$P(Y,";",3,99)
D IXALL^DIK
A ;
W !! S DIC="^DOPT("""_$P($T(+1)," ;")_""",",DIC(0)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
;
1 ;;Update Appointment Status
;
G EN^SDAMQ
;
2 ;;View Log Date (single entry)
;
S SDEF="LAST"
SELECT W !!,"Select APPOINTMENT DATE: "_$S(SDEF]"":SDEF_"// ",1:"") R SDWHEN:DTIME
I '$T!(SDWHEN["^") G Q2
I SDEF="",SDWHEN="" G Q2
I SDEF]"",SDWHEN="" S SDWHEN=SDEF
I $$UPPER^VALM1(SDWHEN)=$E("LAST",1,$L(SDWHEN)) W $E("LAST",$L(SDWHEN)+1,4) S D0=$$LAST() G SHOW:D0 W !,*7,"o update has not completed in the last 100 days" G SELECT
;
S X=SDWHEN,DIC="^SDD(409.65,",DIC(0)="EMQ" D ^DIC K DIC G SELECT:Y<0 S D0=+Y
;
SHOW S SDEF="",X="SDAMXLD" X ^%ZOSF("TEST") I $T W:$D(IOF) @IOF W "Appointment Status Log" K DXS D HEAD^SDAMXLD,^SDAMXLD K DXS G SELECT
S D0=DA,DIC="^SDD(409.65," D EN^DIQ G SELECT
Q2 K SDWHEN,SDEF,D0,Y,X,DA,DIC Q
;
3 ;;View Log Date (date range)
;
N SDT00,SDBD,SDED,BEGDATE,ENDDATE,X
S SDT00="AEX" D DATE^SDUTL G:'$D(SDED) Q3
S L=0,FLDS="[SDAMVLD]",BY="@.01",FR=SDBD,TO=SDED
S DHD="Appointment Status Update Log from "_$$FTIME^VALM1(BEGDATE)_" to "_$$FTIME^VALM1(ENDDATE)
S DIC="^SDD(409.65," D EN1^DIP
Q3 Q
;
4 ;;Purge log entries (data will be kept for current+1 FYs)
;
N SDLFY,SDMAX,SDBD,SDED,BEGDATE,ENDDATE,SDLIM,SDT00,X,Y
S SDLIM=($E(DT,1,3)-$S($E(DT,4,5)>9:1,1:2))_"1001"
W !,"This option will not purge dates beyond " S X1=SDLIM,X2=-1 D C^%DTC S (Y,SDLFY,SDMAX)=X D DT^DIQ W "."
S %DT(0)=-X,SDT00="AEX" D DATE^SDUTL G:'$D(SDED) Q4 S SDCNT=0
I SDED<SDMAX S SDMAX=SDED
S Y=$$QUE
Q
;
EN4 ;
N DIK,SDI,DA,SDCNT
S DIK="^SDD(409.65,",SDCNT=0
F SDI=SDBD:0 S SDI=$O(^SDD(409.65,"B",SDI)) Q:'SDI!(SDI>SDMAX) S DA=$O(^(SDI,0)) D ^DIK S SDCNT=SDCNT+1
D BULL
Q4 Q
;
LAST() ;
; input - no input (user selection of last)
; output - the latest date, beginning day or -100 days
;
N SDI,LAST
F SDI=0:1:100 S X1=DT,X2=-SDI D C^%DTC S LAST=$O(^SDD(409.65,"B",X,0)) S LAST1=$P($G(^SDD(409.65,+LAST,0)),U,5) Q:LAST1
Q LAST
BULL ; Bulletin for purge
N SDLN,SDMSG
K ^TMP("SDAMLBL",$J)
S SDLN=0,XMSUB="APPOINTMENT STATUS UPDATE LOG PURGE" K XMY
S XMTEXT="^TMP(""SDAMLBL"",$J,"
S XMY($S(DUZ:DUZ,1:.5))=""
S XMDUZ=.5 D NOW^%DTC
S SDMSG=" " D SETLN
S SDMSG="The Appointment Status Update Log Purge was completed "_$$FTIME^VALM1(%)_"." D SETLN
S SDMSG=" " D SETLN
S SDMSG=SDCNT_" records were purged from "_$$FDATE^VALM1(SDBD)_" to "_$$FDATE^VALM1(SDED)_"." D SETLN
D ^XMD
K ^TMP("SDAMLBL",$J),XMY,XMTEXT,XMSUB
Q
;
SETLN ; Setting TMP global for bulletin
S SDLN=SDLN+1
S ^TMP("SDAMLBL",$J,SDLN)=SDMSG
Q
QUE() ; -- que job
; return: did job que [ 1|yes 0|no ]
;
K ZTSK,IO("Q")
S ZTIO="",ZTDESC="Appointment Update Log Status Purge",ZTRTN="EN4^SDAMLD"
F X="SDBD","SDED","SDMAX","DUZ" S ZTSAVE(X)=""
D ^%ZTLOAD W:$D(ZTSK) " (Task: ",ZTSK,")"
Q $D(ZTSK)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDAMLD 3197 printed Apr 09, 2024@21:55:57 Page 2
SDAMLD ;ALB/CAW - Ambulartory Status Update Log Utilities ; 3/6/92
+1 ;;5.3;Scheduling;;Aug 13, 1993
+2 ;
EN DO DT^DICRW
SET X=$TEXT(+1)
SET DIK="^DOPT("""_$PIECE(X," ;",1)_""","
+1 if $DATA(^DOPT($PIECE(X," ;"),4))
GOTO A
SET ^DOPT($PIECE(X," ;"),0)=$PIECE(X,";",3)_"^1N^"
FOR I=1:1
SET Y=$TEXT(@I)
if Y=""
QUIT
SET ^DOPT($PIECE(X," ;"),I,0)=$PIECE(Y,";",3,99)
+2 DO IXALL^DIK
A ;
+1 WRITE !!
SET DIC="^DOPT("""_$PIECE($TEXT(+1)," ;")_""","
SET DIC(0)="IQEAM"
DO ^DIC
if Y<0
QUIT
DO @+Y
GOTO A
+2 ;
1 ;;Update Appointment Status
+1 ;
+2 GOTO EN^SDAMQ
+3 ;
2 ;;View Log Date (single entry)
+1 ;
+2 SET SDEF="LAST"
SELECT WRITE !!,"Select APPOINTMENT DATE: "_$SELECT(SDEF]"":SDEF_"// ",1:"")
READ SDWHEN:DTIME
+1 IF '$TEST!(SDWHEN["^")
GOTO Q2
+2 IF SDEF=""
IF SDWHEN=""
GOTO Q2
+3 IF SDEF]""
IF SDWHEN=""
SET SDWHEN=SDEF
+4 IF $$UPPER^VALM1(SDWHEN)=$EXTRACT("LAST",1,$LENGTH(SDWHEN))
WRITE $EXTRACT("LAST",$LENGTH(SDWHEN)+1,4)
SET D0=$$LAST()
if D0
GOTO SHOW
WRITE !,*7,"o update has not completed in the last 100 days"
GOTO SELECT
+5 ;
+6 SET X=SDWHEN
SET DIC="^SDD(409.65,"
SET DIC(0)="EMQ"
DO ^DIC
KILL DIC
if Y<0
GOTO SELECT
SET D0=+Y
+7 ;
SHOW SET SDEF=""
SET X="SDAMXLD"
XECUTE ^%ZOSF("TEST")
IF $TEST
if $DATA(IOF)
WRITE @IOF
WRITE "Appointment Status Log"
KILL DXS
DO HEAD^SDAMXLD
DO ^SDAMXLD
KILL DXS
GOTO SELECT
+1 SET D0=DA
SET DIC="^SDD(409.65,"
DO EN^DIQ
GOTO SELECT
Q2 KILL SDWHEN,SDEF,D0,Y,X,DA,DIC
QUIT
+1 ;
3 ;;View Log Date (date range)
+1 ;
+2 NEW SDT00,SDBD,SDED,BEGDATE,ENDDATE,X
+3 SET SDT00="AEX"
DO DATE^SDUTL
if '$DATA(SDED)
GOTO Q3
+4 SET L=0
SET FLDS="[SDAMVLD]"
SET BY="@.01"
SET FR=SDBD
SET TO=SDED
+5 SET DHD="Appointment Status Update Log from "_$$FTIME^VALM1(BEGDATE)_" to "_$$FTIME^VALM1(ENDDATE)
+6 SET DIC="^SDD(409.65,"
DO EN1^DIP
Q3 QUIT
+1 ;
4 ;;Purge log entries (data will be kept for current+1 FYs)
+1 ;
+2 NEW SDLFY,SDMAX,SDBD,SDED,BEGDATE,ENDDATE,SDLIM,SDT00,X,Y
+3 SET SDLIM=($EXTRACT(DT,1,3)-$SELECT($EXTRACT(DT,4,5)>9:1,1:2))_"1001"
+4 WRITE !,"This option will not purge dates beyond "
SET X1=SDLIM
SET X2=-1
DO C^%DTC
SET (Y,SDLFY,SDMAX)=X
DO DT^DIQ
WRITE "."
+5 SET %DT(0)=-X
SET SDT00="AEX"
DO DATE^SDUTL
if '$DATA(SDED)
GOTO Q4
SET SDCNT=0
+6 IF SDED<SDMAX
SET SDMAX=SDED
+7 SET Y=$$QUE
+8 QUIT
+9 ;
EN4 ;
+1 NEW DIK,SDI,DA,SDCNT
+2 SET DIK="^SDD(409.65,"
SET SDCNT=0
+3 FOR SDI=SDBD:0
SET SDI=$ORDER(^SDD(409.65,"B",SDI))
if 'SDI!(SDI>SDMAX)
QUIT
SET DA=$ORDER(^(SDI,0))
DO ^DIK
SET SDCNT=SDCNT+1
+4 DO BULL
Q4 QUIT
+1 ;
LAST() ;
+1 ; input - no input (user selection of last)
+2 ; output - the latest date, beginning day or -100 days
+3 ;
+4 NEW SDI,LAST
+5 FOR SDI=0:1:100
SET X1=DT
SET X2=-SDI
DO C^%DTC
SET LAST=$ORDER(^SDD(409.65,"B",X,0))
SET LAST1=$PIECE($GET(^SDD(409.65,+LAST,0)),U,5)
if LAST1
QUIT
+6 QUIT LAST
BULL ; Bulletin for purge
+1 NEW SDLN,SDMSG
+2 KILL ^TMP("SDAMLBL",$JOB)
+3 SET SDLN=0
SET XMSUB="APPOINTMENT STATUS UPDATE LOG PURGE"
KILL XMY
+4 SET XMTEXT="^TMP(""SDAMLBL"",$J,"
+5 SET XMY($SELECT(DUZ:DUZ,1:.5))=""
+6 SET XMDUZ=.5
DO NOW^%DTC
+7 SET SDMSG=" "
DO SETLN
+8 SET SDMSG="The Appointment Status Update Log Purge was completed "_$$FTIME^VALM1(%)_"."
DO SETLN
+9 SET SDMSG=" "
DO SETLN
+10 SET SDMSG=SDCNT_" records were purged from "_$$FDATE^VALM1(SDBD)_" to "_$$FDATE^VALM1(SDED)_"."
DO SETLN
+11 DO ^XMD
+12 KILL ^TMP("SDAMLBL",$JOB),XMY,XMTEXT,XMSUB
+13 QUIT
+14 ;
SETLN ; Setting TMP global for bulletin
+1 SET SDLN=SDLN+1
+2 SET ^TMP("SDAMLBL",$JOB,SDLN)=SDMSG
+3 QUIT
QUE() ; -- que job
+1 ; return: did job que [ 1|yes 0|no ]
+2 ;
+3 KILL ZTSK,IO("Q")
+4 SET ZTIO=""
SET ZTDESC="Appointment Update Log Status Purge"
SET ZTRTN="EN4^SDAMLD"
+5 FOR X="SDBD","SDED","SDMAX","DUZ"
SET ZTSAVE(X)=""
+6 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE " (Task: ",ZTSK,")"
+7 QUIT $DATA(ZTSK)
