SDTMPPRC ;TMP/DRF - TMP Clinic Schedule Edit Queueing Routine;Oct 7, 2022
;;5.3;Scheduling;**821**;OCT 7, 2022;Build 9
Q
PROCESS(JOB) ;Process any unprocessed record in SDTMPX queue
;JOB = Job number of the process that produced the clinic edits
;Lock the queue
I $G(JOB)="" Q ;Called incorrectly
I '$D(^XTMP("SDTMPX",0)) S %H=$H D YMD^%DTC S $P(^XTMP("SDTMPX",0),"^",2)=X ;Set up for first run
L +^XTMP("SDTMPX",JOB):5 I '$T Q ;This job's queue is already being processed
N CL,DATE,FUN,FUNSTR,I,J,K,REC,SDEND,SDSTART,SEQ,SEQSTR,TMS,TOTC,TOTUC,X,Y,Z
;Process from piece 2 to piece 1
S SDEND=+$P($G(^XTMP("SDTMPX",JOB,"SEQ")),"^",1),SDSTART=+$P($G(^XTMP("SDTMPX",JOB,"SEQ")),"^",2) ;process what's in the queue now
I SDEND=SDSTART Q ;Nothing new in queue
;Load array
K ^TMP("SDTMPX",JOB)
F I=SDSTART+1:1:SDEND D
. S X=^XTMP("SDTMPX",JOB,I)
. S SEQ=I,CL=$P(X,"^",1),TMS=$P(X,"^",2),DATE=$P(X,"^",3),DUZ=$P(X,"^",4),FUN=$P(X,"^",5)
. S ^TMP("SDTMPX",JOB,CL,DATE,SEQ)=FUN_"^"_DUZ,^XTMP("SDTMPX","B",TMS,JOB,SEQ)=""
;Check array for offsetting transactions
S CL=0 F S CL=$O(^TMP("SDTMPX",JOB,CL)) Q:'CL D
. S DATE=0 F S DATE=$O(^TMP("SDTMPX",JOB,CL,DATE)) Q:'DATE D PROCDATE
S $P(^XTMP("SDTMPX",JOB,"SEQ"),"^",2)=SDEND
K ^TMP("SDTMPX",JOB)
L -^XTMP("SDTMPX",JOB)
D ORPHAN
D PURGE
Q
;
PROCDATE ;Process a single date
S REC=0,FUNSTR=",",SEQSTR=""
S SEQ=0 F S SEQ=$O(^TMP("SDTMPX",JOB,CL,DATE,SEQ)) Q:'SEQ D
. S FUN=$P(^TMP("SDTMPX",JOB,CL,DATE,SEQ),"^",1),DUZ=$P(^TMP("SDTMPX",JOB,CL,DATE,SEQ),"^",2)
. S REC=REC+1,FUNSTR=FUNSTR_FUN_",",SEQSTR=SEQSTR_SEQ_","
S TOTC=0,TOTUC=0 F J=2:1 S Y=$P(FUNSTR,",",J) Q:Y="" S:Y="C" TOTC=TOTC+1 S:Y="UC" TOTUC=TOTUC+1
I REC#2=0,TOTC=TOTUC D Q ;If even number of transactions, all ofsetting, cancel them
. F K=1:1 S Z=$P(SEQSTR,",",K) Q:Z="" S $P(^XTMP("SDTMPX",JOB,Z),"^",6)="O" ;Mark processed offset
I REC,TOTC>TOTUC D
. D EN^SDTMPHLC(CL,DATE,,"C","NO APPOINTMENT AVAILABILITY") ;Appointments previously available, now none - send block transaction
. D MARK("C")
I REC,TOTUC>TOTC D
. D EN^SDTMPHLC(CL,DATE,,"UC","RESTORED BY SDBUILD") ;No appointments previously available, send unblock transaction
. D MARK("UC")
Q
;
MARK(FUN) ;For an odd number of transactions, mark each transaction correct (one sent, the rest offset)
N FUNSTR2,CNT,FUNCNT,SENT
S FUNSTR2=$P(FUNSTR,",",2),SENT=0
S FUNCNT=$L(SEQSTR,",")-1
F CNT=1:1:FUNCNT D
. I $P(FUNSTR2,",",CNT)=FUN,'SENT S $P(^XTMP("SDTMPX",JOB,$P(SEQSTR,",",CNT)),"^",6)="P",SENT=1 Q
. S $P(^XTMP("SDTMPX",JOB,$P(SEQSTR,",",CNT)),"^",6)="O"
Q
;
ORPHAN ;Check for unprocessed entries older than 30 minutes - user may have left Edit A Clinic abnormally
S JOB=0 F S JOB=$O(^XTMP("SDTMPX",JOB)) Q:'JOB D
. S SDEND=+$P($G(^XTMP("SDTMPX",JOB,"SEQ")),"^",1),SDSTART=+$P($G(^XTMP("SDTMPX",JOB,"SEQ")),"^",2) ;process what's in the queue now
. I SDEND=SDSTART Q ;Nothing unprocessed
. S X=^XTMP("SDTMPX",JOB,SDEND),TS=$P(X,"^",2)
. I $P($H,",",2)-$P(TS,",",2)>1800 D PROCESS(JOB) ;More than 30 minutes old so process it
Q
;
PURGE ;Purge history greater than 90 days old
N START,DATE,JOB,SEQ,%H,X
S START=$H-91_","_"00000"
S DATE=START F S DATE=$O(^XTMP("SDTMPX","B",DATE),-1) Q:DATE="" D
. S JOB=0 F S JOB=$O(^XTMP("SDTMPX","B",DATE,JOB),-1) Q:'JOB D
.. K ^XTMP("SDTMPX",JOB),^XTMP("SDTMPX","B",DATE,JOB)
S %H=$H+90 D YMD^%DTC
S $P(^XTMP("SDTMPX",0),"^",1)=X
Q
;
BEGIN ;Report Begin & Title
N %,%H,%T,%Y,CL,DA,DATE,DIC,DIE,DIR,DOW,FUN,JOB,LN,OCL,POP,PRC,SDCLIN,SDLN,SDPG,SDT,SEQ,TS,X,XDATE,XTIME,Y
W #,"TMP Clinic Schedule Edit Transaction List",!!
S DA=0
;
ALLORONE ;All clinics or one clinic
S DIR(0)="S^O:ONE CLINIC;A:ALL CLINICS"
S DIR("A")="ONE CLINIC OR ALL",DIR("B")="A" D ^DIR
I $G(DUOUT)!($G(DTOUT)) G END
S SDCLIN=X
I $$UPPER^SDUL1(SDCLIN)="O" D CLINIC I $G(DUOUT)!($G(DTOUT)) G END
;
IO ;Ask IO device and Queue
S %ZIS="PQM" D ^%ZIS G:POP END
I $D(IO("Q")) D QUE G END
;
LOOP ;Compile Data
K ^TMP("SDTMPPRC")
S %H=$H D YX^%DTC S SDT=$P(Y,"@"),OCL=0
S JOB=0 F S JOB=$O(^XTMP("SDTMPX",JOB)) Q:'JOB D
. S SEQ=0 F S SEQ=$O(^XTMP("SDTMPX",JOB,SEQ)) Q:'SEQ D
.. S X=^XTMP("SDTMPX",JOB,SEQ)
.. S CL=$P(X,"^",1),TS=$P(X,"^",2),DATE=$P(X,"^",3),DUZ=$P(X,"^",4),FUN=$P(X,"^",5),PRC=$P(X,"^",6)
.. S ^TMP("SDTMPPRC",CL,DATE,TS,SEQ)=FUN_"^"_PRC_"^"_DUZ
D PRINT
D END
Q
;
CLINIC ;Clinic prompt
S DIC=44,DIC(0)="MAQEZ",DIC("A")="Select CLINIC NAME: "
F D Q:Y>0!($G(DTOUT))!($G(DUOUT))
. D ^DIC
. I Y<0!(X="") Q
. S DIE=44,DA=+Y
K DIC("A"),DIC("S")
Q
;
PRINT ;Print Data
U IO
S SDPG=0,SDLN=1
I DA S CL=DA D PRINT2
I 'DA S CL=0 F S CL=$O(^TMP("SDTMPPRC",CL)) Q:'CL D PRINT2
W !!,"END OF REPORT"
Q
;
PRINT2 ;Navigate lines in sequence
S DATE=0 F S DATE=$O(^TMP("SDTMPPRC",CL,DATE)) Q:'DATE D
. S TS="" F S TS=$O(^TMP("SDTMPPRC",CL,DATE,TS)) Q:TS="" D
.. S SEQ=0 F S SEQ=$O(^TMP("SDTMPPRC",CL,DATE,TS,SEQ)) Q:'SEQ D
... S LN=^TMP("SDTMPPRC",CL,DATE,TS,SEQ),FUN=$P(LN,"^",1),PRC=$P(LN,"^",2),DUZ=$P(LN,"^",3) D LINE
Q
;
LINE ;Print one line
I CL'=OCL D HEADER
S OCL=CL
I SDLN>(IOSL-4) D HEADER
S SDLN=SDLN+1
S Y=DATE D DD^%DT S XDATE=Y
S X=DATE D DW^%DTC S DOW=X
S %H=TS D YX^%DTC S XTIME=Y
W ?1,XDATE,?15,DOW,?28,$S(FUN="C":"BLOCK",FUN="UC":"UNBLOCK",1:""),?43,$S(PRC="O":"OFFSET",PRC="P":"SENT",1:"UNPROCESSED"),?56,XTIME,?79,$P($G(^VA(200,DUZ,0)),"^",1),!
Q
;
END ;Clean up and Quit
D:'$D(ZTQUEUED) ^%ZISC
K ^TMP("SDTMPPRC"),%ZIS,ZTSAVE,DTOUT,DUOUT
Q
;
S SDPG=SDPG+1,SDLN=1
W #!!," TMP Clinic Schedule Edit Transaction List",?100,SDT,?120,"PAGE: ",SDPG,!
W " CLINIC: ",CL,"-",$P(^SC(CL,0),"^",1),!!
W " DATE DAY OF WEEK BLOCK/UNBLOCK ACTION MODIFIED MODIFIED BY",!
W " ------------ ----------- ------------- ----------- --------------------- --------------------",!
Q
;
QUE ;Run job in background
S ZTRTN="LOOP^SDTMPPRC",ZTDESC="Hospital Location List",ZTSAVE("SD*")=""
D ^%ZTLOAD W:$D(ZTSK) !,"Task #",ZTSK," Started."
D HOME^%ZIS K IO("Q"),ZTSK,ZTDESC,ZTQUEUED,ZTRTN
D END
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDTMPPRC 6226 printed Dec 13, 2024@03:01:36 Page 2
SDTMPPRC ;TMP/DRF - TMP Clinic Schedule Edit Queueing Routine;Oct 7, 2022
+1 ;;5.3;Scheduling;**821**;OCT 7, 2022;Build 9
+2 QUIT
PROCESS(JOB) ;Process any unprocessed record in SDTMPX queue
+1 ;JOB = Job number of the process that produced the clinic edits
+2 ;Lock the queue
+3 ;Called incorrectly
IF $GET(JOB)=""
QUIT
+4 ;Set up for first run
IF '$DATA(^XTMP("SDTMPX",0))
SET %H=$HOROLOG
DO YMD^%DTC
SET $PIECE(^XTMP("SDTMPX",0),"^",2)=X
+5 ;This job's queue is already being processed
LOCK +^XTMP("SDTMPX",JOB):5
IF '$TEST
QUIT
+6 NEW CL,DATE,FUN,FUNSTR,I,J,K,REC,SDEND,SDSTART,SEQ,SEQSTR,TMS,TOTC,TOTUC,X,Y,Z
+7 ;Process from piece 2 to piece 1
+8 ;process what's in the queue now
SET SDEND=+$PIECE($GET(^XTMP("SDTMPX",JOB,"SEQ")),"^",1)
SET SDSTART=+$PIECE($GET(^XTMP("SDTMPX",JOB,"SEQ")),"^",2)
+9 ;Nothing new in queue
IF SDEND=SDSTART
QUIT
+10 ;Load array
+11 KILL ^TMP("SDTMPX",JOB)
+12 FOR I=SDSTART+1:1:SDEND
Begin DoDot:1
+13 SET X=^XTMP("SDTMPX",JOB,I)
+14 SET SEQ=I
SET CL=$PIECE(X,"^",1)
SET TMS=$PIECE(X,"^",2)
SET DATE=$PIECE(X,"^",3)
SET DUZ=$PIECE(X,"^",4)
SET FUN=$PIECE(X,"^",5)
+15 SET ^TMP("SDTMPX",JOB,CL,DATE,SEQ)=FUN_"^"_DUZ
SET ^XTMP("SDTMPX","B",TMS,JOB,SEQ)=""
End DoDot:1
+16 ;Check array for offsetting transactions
+17 SET CL=0
FOR
SET CL=$ORDER(^TMP("SDTMPX",JOB,CL))
if 'CL
QUIT
Begin DoDot:1
+18 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("SDTMPX",JOB,CL,DATE))
if 'DATE
QUIT
DO PROCDATE
End DoDot:1
+19 SET $PIECE(^XTMP("SDTMPX",JOB,"SEQ"),"^",2)=SDEND
+20 KILL ^TMP("SDTMPX",JOB)
+21 LOCK -^XTMP("SDTMPX",JOB)
+22 DO ORPHAN
+23 DO PURGE
+24 QUIT
+25 ;
PROCDATE ;Process a single date
+1 SET REC=0
SET FUNSTR=","
SET SEQSTR=""
+2 SET SEQ=0
FOR
SET SEQ=$ORDER(^TMP("SDTMPX",JOB,CL,DATE,SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+3 SET FUN=$PIECE(^TMP("SDTMPX",JOB,CL,DATE,SEQ),"^",1)
SET DUZ=$PIECE(^TMP("SDTMPX",JOB,CL,DATE,SEQ),"^",2)
+4 SET REC=REC+1
SET FUNSTR=FUNSTR_FUN_","
SET SEQSTR=SEQSTR_SEQ_","
End DoDot:1
+5 SET TOTC=0
SET TOTUC=0
FOR J=2:1
SET Y=$PIECE(FUNSTR,",",J)
if Y=""
QUIT
if Y="C"
SET TOTC=TOTC+1
if Y="UC"
SET TOTUC=TOTUC+1
+6 ;If even number of transactions, all ofsetting, cancel them
IF REC#2=0
IF TOTC=TOTUC
Begin DoDot:1
+7 ;Mark processed offset
FOR K=1:1
SET Z=$PIECE(SEQSTR,",",K)
if Z=""
QUIT
SET $PIECE(^XTMP("SDTMPX",JOB,Z),"^",6)="O"
End DoDot:1
QUIT
+8 IF REC
IF TOTC>TOTUC
Begin DoDot:1
+9 ;Appointments previously available, now none - send block transaction
DO EN^SDTMPHLC(CL,DATE,,"C","NO APPOINTMENT AVAILABILITY")
+10 DO MARK("C")
End DoDot:1
+11 IF REC
IF TOTUC>TOTC
Begin DoDot:1
+12 ;No appointments previously available, send unblock transaction
DO EN^SDTMPHLC(CL,DATE,,"UC","RESTORED BY SDBUILD")
+13 DO MARK("UC")
End DoDot:1
+14 QUIT
+15 ;
MARK(FUN) ;For an odd number of transactions, mark each transaction correct (one sent, the rest offset)
+1 NEW FUNSTR2,CNT,FUNCNT,SENT
+2 SET FUNSTR2=$PIECE(FUNSTR,",",2)
SET SENT=0
+3 SET FUNCNT=$LENGTH(SEQSTR,",")-1
+4 FOR CNT=1:1:FUNCNT
Begin DoDot:1
+5 IF $PIECE(FUNSTR2,",",CNT)=FUN
IF 'SENT
SET $PIECE(^XTMP("SDTMPX",JOB,$PIECE(SEQSTR,",",CNT)),"^",6)="P"
SET SENT=1
QUIT
+6 SET $PIECE(^XTMP("SDTMPX",JOB,$PIECE(SEQSTR,",",CNT)),"^",6)="O"
End DoDot:1
+7 QUIT
+8 ;
ORPHAN ;Check for unprocessed entries older than 30 minutes - user may have left Edit A Clinic abnormally
+1 SET JOB=0
FOR
SET JOB=$ORDER(^XTMP("SDTMPX",JOB))
if 'JOB
QUIT
Begin DoDot:1
+2 ;process what's in the queue now
SET SDEND=+$PIECE($GET(^XTMP("SDTMPX",JOB,"SEQ")),"^",1)
SET SDSTART=+$PIECE($GET(^XTMP("SDTMPX",JOB,"SEQ")),"^",2)
+3 ;Nothing unprocessed
IF SDEND=SDSTART
QUIT
+4 SET X=^XTMP("SDTMPX",JOB,SDEND)
SET TS=$PIECE(X,"^",2)
+5 ;More than 30 minutes old so process it
IF $PIECE($HOROLOG,",",2)-$PIECE(TS,",",2)>1800
DO PROCESS(JOB)
End DoDot:1
+6 QUIT
+7 ;
PURGE ;Purge history greater than 90 days old
+1 NEW START,DATE,JOB,SEQ,%H,X
+2 SET START=$HOROLOG-91_","_"00000"
+3 SET DATE=START
FOR
SET DATE=$ORDER(^XTMP("SDTMPX","B",DATE),-1)
if DATE=""
QUIT
Begin DoDot:1
+4 SET JOB=0
FOR
SET JOB=$ORDER(^XTMP("SDTMPX","B",DATE,JOB),-1)
if 'JOB
QUIT
Begin DoDot:2
+5 KILL ^XTMP("SDTMPX",JOB),^XTMP("SDTMPX","B",DATE,JOB)
End DoDot:2
End DoDot:1
+6 SET %H=$HOROLOG+90
DO YMD^%DTC
+7 SET $PIECE(^XTMP("SDTMPX",0),"^",1)=X
+8 QUIT
+9 ;
BEGIN ;Report Begin & Title
+1 NEW %,%H,%T,%Y,CL,DA,DATE,DIC,DIE,DIR,DOW,FUN,JOB,LN,OCL,POP,PRC,SDCLIN,SDLN,SDPG,SDT,SEQ,TS,X,XDATE,XTIME,Y
+2 WRITE #,"TMP Clinic Schedule Edit Transaction List",!!
+3 SET DA=0
+4 ;
ALLORONE ;All clinics or one clinic
+1 SET DIR(0)="S^O:ONE CLINIC;A:ALL CLINICS"
+2 SET DIR("A")="ONE CLINIC OR ALL"
SET DIR("B")="A"
DO ^DIR
+3 IF $GET(DUOUT)!($GET(DTOUT))
GOTO END
+4 SET SDCLIN=X
+5 IF $$UPPER^SDUL1(SDCLIN)="O"
DO CLINIC
IF $GET(DUOUT)!($GET(DTOUT))
GOTO END
+6 ;
IO ;Ask IO device and Queue
+1 SET %ZIS="PQM"
DO ^%ZIS
if POP
GOTO END
+2 IF $DATA(IO("Q"))
DO QUE
GOTO END
+3 ;
LOOP ;Compile Data
+1 KILL ^TMP("SDTMPPRC")
+2 SET %H=$HOROLOG
DO YX^%DTC
SET SDT=$PIECE(Y,"@")
SET OCL=0
+3 SET JOB=0
FOR
SET JOB=$ORDER(^XTMP("SDTMPX",JOB))
if 'JOB
QUIT
Begin DoDot:1
+4 SET SEQ=0
FOR
SET SEQ=$ORDER(^XTMP("SDTMPX",JOB,SEQ))
if 'SEQ
QUIT
Begin DoDot:2
+5 SET X=^XTMP("SDTMPX",JOB,SEQ)
+6 SET CL=$PIECE(X,"^",1)
SET TS=$PIECE(X,"^",2)
SET DATE=$PIECE(X,"^",3)
SET DUZ=$PIECE(X,"^",4)
SET FUN=$PIECE(X,"^",5)
SET PRC=$PIECE(X,"^",6)
+7 SET ^TMP("SDTMPPRC",CL,DATE,TS,SEQ)=FUN_"^"_PRC_"^"_DUZ
End DoDot:2
End DoDot:1
+8 DO PRINT
+9 DO END
+10 QUIT
+11 ;
CLINIC ;Clinic prompt
+1 SET DIC=44
SET DIC(0)="MAQEZ"
SET DIC("A")="Select CLINIC NAME: "
+2 FOR
Begin DoDot:1
+3 DO ^DIC
+4 IF Y<0!(X="")
QUIT
+5 SET DIE=44
SET DA=+Y
End DoDot:1
if Y>0!($GET(DTOUT))!($GET(DUOUT))
QUIT
+6 KILL DIC("A"),DIC("S")
+7 QUIT
+8 ;
PRINT ;Print Data
+1 USE IO
+2 SET SDPG=0
SET SDLN=1
+3 IF DA
SET CL=DA
DO PRINT2
+4 IF 'DA
SET CL=0
FOR
SET CL=$ORDER(^TMP("SDTMPPRC",CL))
if 'CL
QUIT
DO PRINT2
+5 WRITE !!,"END OF REPORT"
+6 QUIT
+7 ;
PRINT2 ;Navigate lines in sequence
+1 SET DATE=0
FOR
SET DATE=$ORDER(^TMP("SDTMPPRC",CL,DATE))
if 'DATE
QUIT
Begin DoDot:1
+2 SET TS=""
FOR
SET TS=$ORDER(^TMP("SDTMPPRC",CL,DATE,TS))
if TS=""
QUIT
Begin DoDot:2
+3 SET SEQ=0
FOR
SET SEQ=$ORDER(^TMP("SDTMPPRC",CL,DATE,TS,SEQ))
if 'SEQ
QUIT
Begin DoDot:3
+4 SET LN=^TMP("SDTMPPRC",CL,DATE,TS,SEQ)
SET FUN=$PIECE(LN,"^",1)
SET PRC=$PIECE(LN,"^",2)
SET DUZ=$PIECE(LN,"^",3)
DO LINE
End DoDot:3
End DoDot:2
End DoDot:1
+5 QUIT
+6 ;
LINE ;Print one line
+1 IF CL'=OCL
DO HEADER
+2 SET OCL=CL
+3 IF SDLN>(IOSL-4)
DO HEADER
+4 SET SDLN=SDLN+1
+5 SET Y=DATE
DO DD^%DT
SET XDATE=Y
+6 SET X=DATE
DO DW^%DTC
SET DOW=X
+7 SET %H=TS
DO YX^%DTC
SET XTIME=Y
+8 WRITE ?1,XDATE,?15,DOW,?28,$SELECT(FUN="C":"BLOCK",FUN="UC":"UNBLOCK",1:""),?43,$SELECT(PRC="O":"OFFSET",PRC="P":"SENT",1:"UNPROCESSED"),?56,XTIME,?79,$PIECE($GET(^VA(200,DUZ,0)),"^",1),!
+9 QUIT
+10 ;
END ;Clean up and Quit
+1 if '$DATA(ZTQUEUED)
DO ^%ZISC
+2 KILL ^TMP("SDTMPPRC"),%ZIS,ZTSAVE,DTOUT,DUOUT
+3 QUIT
+4 ;
+1 SET SDPG=SDPG+1
SET SDLN=1
+2 WRITE #!!," TMP Clinic Schedule Edit Transaction List",?100,SDT,?120,"PAGE: ",SDPG,!
+3 WRITE " CLINIC: ",CL,"-",$PIECE(^SC(CL,0),"^",1),!!
+4 WRITE " DATE DAY OF WEEK BLOCK/UNBLOCK ACTION MODIFIED MODIFIED BY",!
+5 WRITE " ------------ ----------- ------------- ----------- --------------------- --------------------",!
+6 QUIT
+7 ;
QUE ;Run job in background
+1 SET ZTRTN="LOOP^SDTMPPRC"
SET ZTDESC="Hospital Location List"
SET ZTSAVE("SD*")=""
+2 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Task #",ZTSK," Started."
+3 DO HOME^%ZIS
KILL IO("Q"),ZTSK,ZTDESC,ZTQUEUED,ZTRTN
+4 DO END
+5 QUIT
