- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBGMGR 8793 printed Mar 13, 2025@21:29:39 Page 2
- 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