PSOBGMGR ;BHAM ISC/LC - BINGO BOARD MANAGER ;2/15/06 1:03pm
;;7.0;OUTPATIENT PHARMACY;**12,232,268**;DEC 1997;Build 9
;
;PSO*232 add check for bad ATIC xref and cleanup
;
CODE D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
S:$P($G(^PS(59,PSOSITE,1)),"^",20)'="" DGP=$P($G(^PS(59,PSOSITE,1)),"^",20)
G ERASE:$G(FLAG)=3,STOPIT:$G(FLAG)=2,DISP:$G(FLAG)=1
TEST S DIK="^PS(52.11," F TEST=0:0 S TEST=$O(^PS(52.11,TEST)) Q:'TEST D
.S TEST1=$P($P($G(^(TEST,0)),"^",5),".") I $G(TEST1)<DT S DA=TEST D ^DIK
K DIK,TEST,TEST1
BEGI S ROLL=1,(ZV,ZH,PSOUT,FLG)=0 I $G(IOST(0))']"" W !,"Please check Device Type and try again" Q
S X="IODHLT;IODHLB;IORVOFF;IORVON" D ENDR^%ZISS S TOP=IODHLT,BOT=IODHLB,VOFF=IORVOFF,VON=IORVON K IODHLT,IODHLB,IORVOFF,IORVON,DIC
S:$G(DGP) DIC("B")=DGP S (DIC,DIE)=59.3,DIC(0)="AEQMZ" D ^DIC K DIC Q:+Y'>0 S (ADA,DA)=+Y
I $P($G(^PS(59.3,ADA,3)),"^")=1,'$G(^PS(59.3,ADA,"STOP")) W !,"Board has already been started!",$C(7) G END
S COLM=$P($G(^PS(59.3,ADA,3)),"^",5),DWT=$P($G(^(3)),"^",6),NWT=$P($G(^(3)),"^",7)
S FTX="PRESCRIPTIONS ARE READY FOR:"
S ^PS(59.3,ADA,"STOP")=0,STOP=0 S TCK=$P(^PS(59.3,ADA,0),"^",2) I $G(TCK)="T" D TICKDV G END
D DEV^PSOBGMG1 W:$G(NODV) !,"No device selected." G END
ANAME G:$G(^PS(59.3,ADA,"STOP")) END H:ZV 20
I $P($G(^PS(59.3,ADA,3)),"^")=1&($P($G(^PS(59.3,ADA,3)),"^",4)'="") D
.D NOW^%DTC S:$E($P($G(%),".",2),1,4)'<$E($P($P($G(^PS(59.3,ADA,3)),"^",4),".",2),1,4) ^PS(59.3,ADA,"STOP")=1,STOP=1 D:STOP ASTOP^PSOBGMG2
D:$G(DWT) WAIT^PSOBGMG1
W @IOF F NOTE=0:0 S NOTE=$O(^PS(59.3,ADA,2,NOTE)) Q:'NOTE!($G(^PS(59.3,ADA,"STOP"))) S NOTES=^PS(59.3,ADA,2,NOTE,0) W !?2,TOP,NOTES,!?2,BOT,NOTES H 3
G:$G(^PS(59.3,ADA,"STOP")) END W @IOF
I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,!
S ZH=$S($G(COLM):1,1:10),ZV=4 S:$G(DWT) ZV=6
S NAME="" F S NAME=$O(^PS(52.11,"ANAM",ADA,NAME)) Q:""[NAME!($G(^PS(59.3,ADA,"STOP"))) D
.I '$G(COLM) D INDX^PSOBGMG1 I ZV>18 D
..H 20 W @IOF I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
..S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,! S ZV=4,ZH=10 S:$G(DWT) ZV=6
.I $G(COLM) D INDX^PSOBGMG1 I ZV>18,ZH>39 D
..H 20 W @IOF I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
..S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,! S ZV=4,ZH=1 S:$G(DWT) ZV=6
.I $G(COLM),ZH>39 S ZV=ZV+2,ZH=1
.S DX=ZH,DY=ZV X IOXY W TOP,$E(NAME,1,18) S DY=DY+1 X IOXY W BOT,$E(NAME,1,18),! S:'$G(COLM) ZV=ZV+2 S:$G(COLM) ZH=ZH+20 Q:$G(^PS(59.3,ADA,"STOP"))
G:$G(^PS(59.3,ADA,"STOP")) END Q:STOP G ANAME
TICKDV D DEV^PSOBGMG1 W:$G(NODV) !,"No device selected." G END
TICKET G:$G(^PS(59.3,ADA,"STOP")) END H:ZV 20
I $P($G(^PS(59.3,ADA,3)),"^")=1&($P($G(^PS(59.3,ADA,3)),"^",4)'="") D
.D NOW^%DTC S:$E($P($G(%),".",2),1,4)'<$E($P($P($G(^PS(59.3,ADA,3)),"^",4),".",2),1,4) ^PS(59.3,ADA,"STOP")=1,STOP=1 D:STOP ASTOP^PSOBGMG2
D:$G(DWT) WAIT^PSOBGMG1
W @IOF F NOTE=0:0 S NOTE=$O(^PS(59.3,ADA,2,NOTE)) Q:'NOTE!($G(^PS(59.3,ADA,"STOP"))) S NOTES=^PS(59.3,ADA,2,NOTE,0) W !?2,TOP,NOTES,!?2,BOT,NOTES H 3
G:$G(^PS(59.3,ADA,"STOP")) END W @IOF
I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,!
S ZH=$S($G(COLM):1,1:15),ZV=4 S:$G(DWT) ZV=6
S TICK="" F S TICK=$O(^PS(52.11,"ATIC",ADA,TICK)) Q:'TICK!($G(^PS(59.3,ADA,"STOP"))) D
.;check for Bad records and kill orphaned xrefs PSO*232
.I $$ATICCHK(ADA,TICK) Q
.I ZV>20 D
..H 20 W @IOF I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
..S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,! S ZV=4,ZH=$S($G(COLM):1,1:15) S:$G(DWT) ZV=6
.I $G(COLM),ZH>16 S ZV=ZV+2,ZH=1
.S DX=ZH,DY=ZV X IOXY W TOP,TICK S DY=DY+1 X IOXY W BOT,TICK,! S:'$G(COLM) ZV=ZV+2 S:$G(COLM) ZH=ZH+8
G:$G(^PS(59.3,ADA,"STOP")) END I '$G(COLM),ZV<6 H 20
I ($G(COLM))&(ZV<6)&(ZH<39) H 20
G TICKET
STOPIT K DIC S:$G(DGP) DIC("B")=DGP S (DIC,DIE)=59.3,DIC(0)="AEQMZ" D ^DIC K DIC Q:+Y'>0 S (ADA,DA)=+Y
I $G(^PS(59.3,ADA,"STOP")) W !!,$C(7),"Board has already been stopped."
I S DIR("A")="Do you want to purge the remaining entries for this display group",DIR(0)="YO",DIR("B")="N" D ^DIR K DIR G:$G(DIRUT) STOPEX G:Y PRG I 'Y W !!,"No data purged." G STOPEX
S ^PS(59.3,ADA,"STOP")=1,STOP=1 W !!,"Board Stopped!!",!!
CNT S CNT1=0 F CNT=0:0 S CNT=$O(^PS(52.11,CNT)) Q:'CNT S:$P($G(^PS(52.11,CNT,0)),"^",3)=ADA CNT1=CNT1+1
I 'CNT1 W !!,"There are no entries to purge from the display group.",! G STOPEX
W !!,$C(7),CNT1," entries still remain in the display group.",!
PRG K DIR S DIR(0)="YO",DIR("A")="Purge this display's data now",DIR("B")="N" D ^DIR K DIR G:$D(DIRUT) STOPEX I 'Y W !!,"No data purged." G STOPEX
W !!,"Purging data. Please wait."
S DIK="^PS(52.11,",DA=0 F S DA=$O(^PS(52.11,DA)) Q:'DA D:$P($G(^PS(52.11,DA,0)),"^",3)=ADA ^DIK
W " Purge complete!",!
STOPEX K ADA,AS,CNT,CNT1,DA,DIK,DIRUT,FLAG,STOP,Y Q
DISP W !! K DIC,DA,DR
S (DIC,DIE,DLAYGO)=59.3,DIC(0)="AELQMZ" D ^DIC K DIC G:+Y'>0 DISPEX S (ADA,DA)=+Y I $G(^PS(59.3,ADA,"STOP"))=0 W !!,$C(7),"This display group has been started.",!,"It must be stopped before you can edit it." G DISPEX
W !! S DR="[PSO DISPLAY EDIT]",DIE("NO^")="BACKOUTOK" L +^PS(59.3,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) G:'$T DISPEX1
D ^DIE G:'$D(DA) DISP L -^PS(59.3,DA) G:'$D(^PS(59.3,DA,2,0)) DISP G:$G(DIRUT) DISPEX1
;
I '$D(Y),$P($G(^PS(59.3,DA,0)),"^",4),$P($G(^PS(59.3,DA,3)),"^") K DIR S DIR(0)="Y",DIR("A")="Do you want to initialize auto-start now",DIR("B")="NO" D ^DIR K DIR G:$D(DIRUT) DISPEX1 S EDT=Y
I $G(EDT) D STRTM^PSOBGMG2 G:'$G(EDT) DISPEX1 D INIJ^PSOBGMG2
DISPEX1 K EDT,DIE,DIR,DR Q
;
ATICCHK(DV,TK) ;check ATIC xref if points to non-existent recs, then cleanup
; Return 0 - if no cleanup
; 1 - if had to cleanup
;
Q:($G(DV)="")!($G(TK)="") 0
N QT,P52 S P52=$O(^PS(52.11,"ATIC",DV,TK,"")),QT=0
;if record pointed to is no longer on file (probably deleted),
;then insure no orphanned xrefs
I '$D(^PS(52.11,P52)) D S QT=1
. K ^PS(52.11,"ATIC",DV,TK,P52)
. K ^PS(52.11,"ANAMK",P52)
. K ^PS(52.11,"ANAM",DV,TK,P52)
. K ^PS(52.11,"C",TK,P52)
. K ^PS(52.11,"AD",DV,P52)
. N PA,PAI
. S PA="" F S PA=$O(^PS(52.11,"ANAM",DV,PA)) Q:PA="" D
. . S PAI="" F S PAI=$O(^PS(52.11,"ANAM",DV,PA,PAI)) Q:PAI="" D
. . . I PAI=P52 K ^PS(52.11,"ANAM",DV,PA,PAI)
Q QT
;
TEXT ;display text about setting up dedicated device
W !!,"In order to automatically start and stop the bingo board monitor,"
W !,"a dedicated device must be setup by your IRM Service.",!!
W "Once a dedicated device is setup, the bingo board can be scheduled"
W !,"to automatically start and/or stop at user-defined times."
W !!,"Enter 'NO' at the DISPLAY SETUP HELP TEXT prompt to not display this help text.",!
Q
;
K ^UTILITY($J,"W") S DIWL=1,DIWR=40,DIWF="C40" F NODE=0:0 S NODE=$O(^PS(59.3,DA,2,NODE)) Q:'NODE S X=^(NODE,0) D ^DIWP
F NODE=0:0 S NODE=$O(^UTILITY($J,"W",1,NODE)) Q:'NODE S NODE1=^(NODE,0) S ^PS(59.3,DA,2,NODE,0)=NODE1,$P(^PS(59.3,DA,2,0),"^",3)=NODE,$P(^(0),"^",4)=NODE S LNODE=NODE
N LAST F NODE=0:0 S NODE=$O(^PS(59.3,DA,2,NODE)) Q:'NODE S LAST=NODE
I LAST>LNODE S DA(1)=DA,DIK="^PS(59.3,"_DA(1)_",2,",DA=LNODE F S DA=$O(^PS(59.3,DA(1),2,DA)) Q:'DA D ^DIK
G DISP
DISPEX K ADA,DA,FLAG,LAST,LNODE,NODE,NODE1,^UTILITY($J,"W"),X,Y Q
ERASE S REC=$O(^PS(52.11,0)) I 'REC W !!,"All data has been purged!" K REC Q
W !! K DIR S DIR("A")="Purge patient data for all or a specific display group",DIR(0)="SBO^A:All display groups;S:Specific display group"
S DIR("?")="Enter 'A' to delete all patient data from all display groups.",DIR("?",1)="Enter 'S' to delete all patient data from a specific display group." D ^DIR K DIR G:$G(DIRUT) END1 S AS=Y K Y
S:$G(DGP) DIC("B")=DGP
G:AS="A" ALL S DIC=59.3,DIC(0)="AEQMZ" D ^DIC K DIC G:+Y'>0 ERASE S ADA=+Y K Y D CNT G ERASE
ALL W !!,$C(7),"*** THIS WILL PURGE ALL BINGO BOARD PATIENT DATA FOR ALL DISPLAY GROUPS. ***",!!
S DIR(0)="YO",DIR("A")="Purge now",DIR("B")="N" D ^DIR K DIR G:$G(DIRUT) ERASE W:Y !!,"Purging data. Please wait..." I 'Y W !!,"No data purged!" G ERASE
PUR S DIK="^PS(52.11,",DA=0 F S DA=$O(^PS(52.11,DA)) Q:'DA D ^DIK
K DIR,DIK,DA W " Purge complete.",! G ERASE
END S ZTREQ="@" I $G(ADA)'="" S:$G(^PS(59.3,ADA,"STOP")) STOP=1
END1 K ADA,AGROUP,BIG,BIGO,BOT,CNT,CNT1,DA,DGP,DR,FLAG,GROUP,NOTE,NAME,NOTES,PSOUT,ROLL,TICK,TOP,X,X1,Y,ZV,ZH,TCK,FTX,COLM,DIWF,DIWL,DIWR,FLG,VOFF,VON
K %,%ZIS,AWT,AWT1,AWT2,BBH,BBM,DEV,DLAYGO,DTOUT,DV,DWT,DX,DY,EN,IOXY,NTXT,NUM,NWT,POP,TASK,TTX,WTT
I $G(STOP) K STOP W @IOF D ^%ZISC G H^XUS
K STOP Q
PSOBGMGR ;BHAM ISC/LC - BINGO BOARD MANAGER ;2/15/06 1:03pm
+1 ;;7.0;OUTPATIENT PHARMACY;**12,232,268**;DEC 1997;Build 9
+2 ;
+3 ;PSO*232 add check for bad ATIC xref and cleanup
+4 ;
CODE IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
GOTO END
+1 IF $PIECE($GET(^PS(59,PSOSITE,1)),"^",20)'=""
SET DGP=$PIECE($GET(^PS(59,PSOSITE,1)),"^",20)
+2 IF $GET(FLAG)=3
GOTO ERASE
IF $GET(FLAG)=2
GOTO STOPIT
IF $GET(FLAG)=1
GOTO DISP
TEST SET DIK="^PS(52.11,"
FOR TEST=0:0
SET TEST=$ORDER(^PS(52.11,TEST))
IF 'TEST
QUIT
Begin DoDot:1
+1 SET TEST1=$PIECE($PIECE($GET(^(TEST,0)),"^",5),".")
IF $GET(TEST1)<DT
SET DA=TEST
DO ^DIK
End DoDot:1
+2 KILL DIK,TEST,TEST1
BEGI SET ROLL=1
SET (ZV,ZH,PSOUT,FLG)=0
IF $GET(IOST(0))']""
WRITE !,"Please check Device Type and try again"
QUIT
+1 SET X="IODHLT;IODHLB;IORVOFF;IORVON"
DO ENDR^%ZISS
SET TOP=IODHLT
SET BOT=IODHLB
SET VOFF=IORVOFF
SET VON=IORVON
KILL IODHLT,IODHLB,IORVOFF,IORVON,DIC
+2 IF $GET(DGP)
SET DIC("B")=DGP
SET (DIC,DIE)=59.3
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
IF +Y'>0
QUIT
SET (ADA,DA)=+Y
+3 IF $PIECE($GET(^PS(59.3,ADA,3)),"^")=1
IF '$GET(^PS(59.3,ADA,"STOP"))
WRITE !,"Board has already been started!",$CHAR(7)
GOTO END
+4 SET COLM=$PIECE($GET(^PS(59.3,ADA,3)),"^",5)
SET DWT=$PIECE($GET(^(3)),"^",6)
SET NWT=$PIECE($GET(^(3)),"^",7)
+5 SET FTX="PRESCRIPTIONS ARE READY FOR:"
+6 SET ^PS(59.3,ADA,"STOP")=0
SET STOP=0
SET TCK=$PIECE(^PS(59.3,ADA,0),"^",2)
IF $GET(TCK)="T"
DO TICKDV
GOTO END
+7 DO DEV^PSOBGMG1
IF $GET(NODV)
WRITE !,"No device selected."
GOTO END
ANAME IF $GET(^PS(59.3,ADA,"STOP"))
GOTO END
IF ZV
HANG 20
+1 IF $PIECE($GET(^PS(59.3,ADA,3)),"^")=1&($PIECE($GET(^PS(59.3,ADA,3)),"^",4)'="")
Begin DoDot:1
+2 DO NOW^%DTC
IF $EXTRACT($PIECE($GET(%),".",2),1,4)'<$EXTRACT($PIECE($PIECE($GET(^PS(59.3,ADA,3)),"^",4),".",2),1,4)
SET ^PS(59.3,ADA,"STOP")=1
SET STOP=1
IF STOP
DO ASTOP^PSOBGMG2
End DoDot:1
+3 IF $GET(DWT)
DO WAIT^PSOBGMG1
+4 WRITE @IOF
FOR NOTE=0:0
SET NOTE=$ORDER(^PS(59.3,ADA,2,NOTE))
IF 'NOTE!($GET(^PS(59.3,ADA,"STOP")))
QUIT
SET NOTES=^PS(59.3,ADA,2,NOTE,0)
WRITE !?2,TOP,NOTES,!?2,BOT,NOTES
HANG 3
+5 IF $GET(^PS(59.3,ADA,"STOP"))
GOTO END
WRITE @IOF
+6 IF $GET(DWT)
SET DX=1
SET DY=1
XECUTE IOXY
WRITE TOP,TTX,!?1,BOT,TTX,!
+7 SET DX=1
SET DY=1
IF $GET(DWT)
SET DY=3
XECUTE IOXY
WRITE TOP,FTX
SET DY=DY+1
XECUTE IOXY
WRITE BOT,FTX,!
+8 SET ZH=$SELECT($GET(COLM):1,1:10)
SET ZV=4
IF $GET(DWT)
SET ZV=6
+9 SET NAME=""
FOR
SET NAME=$ORDER(^PS(52.11,"ANAM",ADA,NAME))
IF ""[NAME!($GET(^PS(59.3,ADA,"STOP")))
QUIT
Begin DoDot:1
+10 IF '$GET(COLM)
DO INDX^PSOBGMG1
IF ZV>18
Begin DoDot:2
+11 HANG 20
WRITE @IOF
IF $GET(DWT)
SET DX=1
SET DY=1
XECUTE IOXY
WRITE TOP,TTX,!?1,BOT,TTX,!
+12 SET DX=1
SET DY=1
IF $GET(DWT)
SET DY=3
XECUTE IOXY
WRITE TOP,FTX
SET DY=DY+1
XECUTE IOXY
WRITE BOT,FTX,!
SET ZV=4
SET ZH=10
IF $GET(DWT)
SET ZV=6
End DoDot:2
+13 IF $GET(COLM)
DO INDX^PSOBGMG1
IF ZV>18
IF ZH>39
Begin DoDot:2
+14 HANG 20
WRITE @IOF
IF $GET(DWT)
SET DX=1
SET DY=1
XECUTE IOXY
WRITE TOP,TTX,!?1,BOT,TTX,!
+15 SET DX=1
SET DY=1
IF $GET(DWT)
SET DY=3
XECUTE IOXY
WRITE TOP,FTX
SET DY=DY+1
XECUTE IOXY
WRITE BOT,FTX,!
SET ZV=4
SET ZH=1
IF $GET(DWT)
SET ZV=6
End DoDot:2
+16 IF $GET(COLM)
IF ZH>39
SET ZV=ZV+2
SET ZH=1
+17 SET DX=ZH
SET DY=ZV
XECUTE IOXY
WRITE TOP,$EXTRACT(NAME,1,18)
SET DY=DY+1
XECUTE IOXY
WRITE BOT,$EXTRACT(NAME,1,18),!
IF '$GET(COLM)
SET ZV=ZV+2
IF $GET(COLM)
SET ZH=ZH+20
IF $GET(^PS(59.3,ADA,"STOP"))
QUIT
End DoDot:1
+18 IF $GET(^PS(59.3,ADA,"STOP"))
GOTO END
IF STOP
QUIT
GOTO ANAME
TICKDV DO DEV^PSOBGMG1
IF $GET(NODV)
WRITE !,"No device selected."
GOTO END
TICKET IF $GET(^PS(59.3,ADA,"STOP"))
GOTO END
IF ZV
HANG 20
+1 IF $PIECE($GET(^PS(59.3,ADA,3)),"^")=1&($PIECE($GET(^PS(59.3,ADA,3)),"^",4)'="")
Begin DoDot:1
+2 DO NOW^%DTC
IF $EXTRACT($PIECE($GET(%),".",2),1,4)'<$EXTRACT($PIECE($PIECE($GET(^PS(59.3,ADA,3)),"^",4),".",2),1,4)
SET ^PS(59.3,ADA,"STOP")=1
SET STOP=1
IF STOP
DO ASTOP^PSOBGMG2
End DoDot:1
+3 IF $GET(DWT)
DO WAIT^PSOBGMG1
+4 WRITE @IOF
FOR NOTE=0:0
SET NOTE=$ORDER(^PS(59.3,ADA,2,NOTE))
IF 'NOTE!($GET(^PS(59.3,ADA,"STOP")))
QUIT
SET NOTES=^PS(59.3,ADA,2,NOTE,0)
WRITE !?2,TOP,NOTES,!?2,BOT,NOTES
HANG 3
+5 IF $GET(^PS(59.3,ADA,"STOP"))
GOTO END
WRITE @IOF
+6 IF $GET(DWT)
SET DX=1
SET DY=1
XECUTE IOXY
WRITE TOP,TTX,!?1,BOT,TTX,!
+7 SET DX=1
SET DY=1
IF $GET(DWT)
SET DY=3
XECUTE IOXY
WRITE TOP,FTX
SET DY=DY+1
XECUTE IOXY
WRITE BOT,FTX,!
+8 SET ZH=$SELECT($GET(COLM):1,1:15)
SET ZV=4
IF $GET(DWT)
SET ZV=6
+9 SET TICK=""
FOR
SET TICK=$ORDER(^PS(52.11,"ATIC",ADA,TICK))
IF 'TICK!($GET(^PS(59.3,ADA,"STOP")))
QUIT
Begin DoDot:1
+10 ;check for Bad records and kill orphaned xrefs PSO*232
+11 IF $$ATICCHK(ADA,TICK)
QUIT
+12 IF ZV>20
Begin DoDot:2
+13 HANG 20
WRITE @IOF
IF $GET(DWT)
SET DX=1
SET DY=1
XECUTE IOXY
WRITE TOP,TTX,!?1,BOT,TTX,!
+14 SET DX=1
SET DY=1
IF $GET(DWT)
SET DY=3
XECUTE IOXY
WRITE TOP,FTX
SET DY=DY+1
XECUTE IOXY
WRITE BOT,FTX,!
SET ZV=4
SET ZH=$SELECT($GET(COLM):1,1:15)
IF $GET(DWT)
SET ZV=6
End DoDot:2
+15 IF $GET(COLM)
IF ZH>16
SET ZV=ZV+2
SET ZH=1
+16 SET DX=ZH
SET DY=ZV
XECUTE IOXY
WRITE TOP,TICK
SET DY=DY+1
XECUTE IOXY
WRITE BOT,TICK,!
IF '$GET(COLM)
SET ZV=ZV+2
IF $GET(COLM)
SET ZH=ZH+8
End DoDot:1
+17 IF $GET(^PS(59.3,ADA,"STOP"))
GOTO END
IF '$GET(COLM)
IF ZV<6
HANG 20
+18 IF ($GET(COLM))&(ZV<6)&(ZH<39)
HANG 20
+19 GOTO TICKET
STOPIT KILL DIC
IF $GET(DGP)
SET DIC("B")=DGP
SET (DIC,DIE)=59.3
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
IF +Y'>0
QUIT
SET (ADA,DA)=+Y
+1 IF $GET(^PS(59.3,ADA,"STOP"))
WRITE !!,$CHAR(7),"Board has already been stopped."
+2 IF $TEST
SET DIR("A")="Do you want to purge the remaining entries for this display group"
SET DIR(0)="YO"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
GOTO STOPEX
IF Y
GOTO PRG
IF 'Y
WRITE !!,"No data purged."
GOTO STOPEX
+3 SET ^PS(59.3,ADA,"STOP")=1
SET STOP=1
WRITE !!,"Board Stopped!!",!!
CNT SET CNT1=0
FOR CNT=0:0
SET CNT=$ORDER(^PS(52.11,CNT))
IF 'CNT
QUIT
IF $PIECE($GET(^PS(52.11,CNT,0)),"^",3)=ADA
SET CNT1=CNT1+1
+1 IF 'CNT1
WRITE !!,"There are no entries to purge from the display group.",!
GOTO STOPEX
+2 WRITE !!,$CHAR(7),CNT1," entries still remain in the display group.",!
PRG KILL DIR
SET DIR(0)="YO"
SET DIR("A")="Purge this display's data now"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO STOPEX
IF 'Y
WRITE !!,"No data purged."
GOTO STOPEX
+1 WRITE !!,"Purging data. Please wait."
+2 SET DIK="^PS(52.11,"
SET DA=0
FOR
SET DA=$ORDER(^PS(52.11,DA))
IF 'DA
QUIT
IF $PIECE($GET(^PS(52.11,DA,0)),"^",3)=ADA
DO ^DIK
+3 WRITE " Purge complete!",!
STOPEX KILL ADA,AS,CNT,CNT1,DA,DIK,DIRUT,FLAG,STOP,Y
QUIT
DISP WRITE !!
KILL DIC,DA,DR
+1 SET (DIC,DIE,DLAYGO)=59.3
SET DIC(0)="AELQMZ"
DO ^DIC
KILL DIC
IF +Y'>0
GOTO DISPEX
SET (ADA,DA)=+Y
IF $GET(^PS(59.3,ADA,"STOP"))=0
WRITE !!,$CHAR(7),"This display group has been started.",!,"It must be stopped before you can edit it."
GOTO DISPEX
+2 WRITE !!
SET DR="[PSO DISPLAY EDIT]"
SET DIE("NO^")="BACKOUTOK"
LOCK +^PS(59.3,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
GOTO DISPEX1
+3 DO ^DIE
IF '$DATA(DA)
GOTO DISP
LOCK -^PS(59.3,DA)
IF '$DATA(^PS(59.3,DA,2,0))
GOTO DISP
IF $GET(DIRUT)
GOTO DISPEX1
+4 ;
+5 IF '$DATA(Y)
IF $PIECE($GET(^PS(59.3,DA,0)),"^",4)
IF $PIECE($GET(^PS(59.3,DA,3)),"^")
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Do you want to initialize auto-start now"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO DISPEX1
SET EDT=Y
+6 IF $GET(EDT)
DO STRTM^PSOBGMG2
IF '$GET(EDT)
GOTO DISPEX1
DO INIJ^PSOBGMG2
DISPEX1 KILL EDT,DIE,DIR,DR
QUIT
+1 ;
ATICCHK(DV,TK) ;check ATIC xref if points to non-existent recs, then cleanup
+1 ; Return 0 - if no cleanup
+2 ; 1 - if had to cleanup
+3 ;
+4 IF ($GET(DV)="")!($GET(TK)="")
QUIT 0
+5 NEW QT,P52
SET P52=$ORDER(^PS(52.11,"ATIC",DV,TK,""))
SET QT=0
+6 ;if record pointed to is no longer on file (probably deleted),
+7 ;then insure no orphanned xrefs
+8 IF '$DATA(^PS(52.11,P52))
Begin DoDot:1
+9 KILL ^PS(52.11,"ATIC",DV,TK,P52)
+10 KILL ^PS(52.11,"ANAMK",P52)
+11 KILL ^PS(52.11,"ANAM",DV,TK,P52)
+12 KILL ^PS(52.11,"C",TK,P52)
+13 KILL ^PS(52.11,"AD",DV,P52)
+14 NEW PA,PAI
+15 SET PA=""
FOR
SET PA=$ORDER(^PS(52.11,"ANAM",DV,PA))
IF PA=""
QUIT
Begin DoDot:2
+16 SET PAI=""
FOR
SET PAI=$ORDER(^PS(52.11,"ANAM",DV,PA,PAI))
IF PAI=""
QUIT
Begin DoDot:3
+17 IF PAI=P52
KILL ^PS(52.11,"ANAM",DV,PA,PAI)
End DoDot:3
End DoDot:2
End DoDot:1
SET QT=1
+18 QUIT QT
+19 ;
TEXT ;display text about setting up dedicated device
+1 WRITE !!,"In order to automatically start and stop the bingo board monitor,"
+2 WRITE !,"a dedicated device must be setup by your IRM Service.",!!
+3 WRITE "Once a dedicated device is setup, the bingo board can be scheduled"
+4 WRITE !,"to automatically start and/or stop at user-defined times."
+5 WRITE !!,"Enter 'NO' at the DISPLAY SETUP HELP TEXT prompt to not display this help text.",!
+6 QUIT
+7 ;
+8 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=40
SET DIWF="C40"
FOR NODE=0:0
SET NODE=$ORDER(^PS(59.3,DA,2,NODE))
IF 'NODE
QUIT
SET X=^(NODE,0)
DO ^DIWP
+9 FOR NODE=0:0
SET NODE=$ORDER(^UTILITY($JOB,"W",1,NODE))
IF 'NODE
QUIT
SET NODE1=^(NODE,0)
SET ^PS(59.3,DA,2,NODE,0)=NODE1
SET $PIECE(^PS(59.3,DA,2,0),"^",3)=NODE
SET $PIECE(^(0),"^",4)=NODE
SET LNODE=NODE
+10 NEW LAST
FOR NODE=0:0
SET NODE=$ORDER(^PS(59.3,DA,2,NODE))
IF 'NODE
QUIT
SET LAST=NODE
+11 IF LAST>LNODE
SET DA(1)=DA
SET DIK="^PS(59.3,"_DA(1)_",2,"
SET DA=LNODE
FOR
SET DA=$ORDER(^PS(59.3,DA(1),2,DA))
IF 'DA
QUIT
DO ^DIK
+12 GOTO DISP
DISPEX KILL ADA,DA,FLAG,LAST,LNODE,NODE,NODE1,^UTILITY($JOB,"W"),X,Y
QUIT
ERASE SET REC=$ORDER(^PS(52.11,0))
IF 'REC
WRITE !!,"All data has been purged!"
KILL REC
QUIT
+1 WRITE !!
KILL DIR
SET DIR("A")="Purge patient data for all or a specific display group"
SET DIR(0)="SBO^A:All display groups;S:Specific display group"
+2 SET DIR("?")="Enter 'A' to delete all patient data from all display groups."
SET DIR("?",1)="Enter 'S' to delete all patient data from a specific display group."
DO ^DIR
KILL DIR
IF $GET(DIRUT)
GOTO END1
SET AS=Y
KILL Y
+3 IF $GET(DGP)
SET DIC("B")=DGP
+4 IF AS="A"
GOTO ALL
SET DIC=59.3
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
IF +Y'>0
GOTO ERASE
SET ADA=+Y
KILL Y
DO CNT
GOTO ERASE
ALL WRITE !!,$CHAR(7),"*** THIS WILL PURGE ALL BINGO BOARD PATIENT DATA FOR ALL DISPLAY GROUPS. ***",!!
+1 SET DIR(0)="YO"
SET DIR("A")="Purge now"
SET DIR("B")="N"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
GOTO ERASE
IF Y
WRITE !!,"Purging data. Please wait..."
IF 'Y
WRITE !!,"No data purged!"
GOTO ERASE
PUR SET DIK="^PS(52.11,"
SET DA=0
FOR
SET DA=$ORDER(^PS(52.11,DA))
IF 'DA
QUIT
DO ^DIK
+1 KILL DIR,DIK,DA
WRITE " Purge complete.",!
GOTO ERASE
END SET ZTREQ="@"
IF $GET(ADA)'=""
IF $GET(^PS(59.3,ADA,"STOP"))
SET STOP=1
END1 KILL ADA,AGROUP,BIG,BIGO,BOT,CNT,CNT1,DA,DGP,DR,FLAG,GROUP,NOTE,NAME,NOTES,PSOUT,ROLL,TICK,TOP,X,X1,Y,ZV,ZH,TCK,FTX,COLM,DIWF,DIWL,DIWR,FLG,VOFF,VON
+1 KILL %,%ZIS,AWT,AWT1,AWT2,BBH,BBM,DEV,DLAYGO,DTOUT,DV,DWT,DX,DY,EN,IOXY,NTXT,NUM,NWT,POP,TASK,TTX,WTT
+2 IF $GET(STOP)
KILL STOP
WRITE @IOF
DO ^%ZISC
GOTO H^XUS
+3 KILL STOP
QUIT
