source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBGMGR.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1PSOBGMGR ;BHAM ISC/LC - BINGO BOARD MANAGER ;2/15/06 1:03pm
2 ;;7.0;OUTPATIENT PHARMACY;**12,232,268**;DEC 1997;Build 9
3 ;
4 ;PSO*232 add check for bad ATIC xref and cleanup
5 ;
6CODE D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
7 S:$P($G(^PS(59,PSOSITE,1)),"^",20)'="" DGP=$P($G(^PS(59,PSOSITE,1)),"^",20)
8 G ERASE:$G(FLAG)=3,STOPIT:$G(FLAG)=2,DISP:$G(FLAG)=1
9TEST S DIK="^PS(52.11," F TEST=0:0 S TEST=$O(^PS(52.11,TEST)) Q:'TEST D
10 .S TEST1=$P($P($G(^(TEST,0)),"^",5),".") I $G(TEST1)<DT S DA=TEST D ^DIK
11 K DIK,TEST,TEST1
12BEGI S ROLL=1,(ZV,ZH,PSOUT,FLG)=0 I $G(IOST(0))']"" W !,"Please check Device Type and try again" Q
13 S X="IODHLT;IODHLB;IORVOFF;IORVON" D ENDR^%ZISS S TOP=IODHLT,BOT=IODHLB,VOFF=IORVOFF,VON=IORVON K IODHLT,IODHLB,IORVOFF,IORVON,DIC
14 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
15 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
16 S COLM=$P($G(^PS(59.3,ADA,3)),"^",5),DWT=$P($G(^(3)),"^",6),NWT=$P($G(^(3)),"^",7)
17 S FTX="PRESCRIPTIONS ARE READY FOR:"
18 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
19 D DEV^PSOBGMG1 W:$G(NODV) !,"No device selected." G END
20ANAME G:$G(^PS(59.3,ADA,"STOP")) END H:ZV 20
21 I $P($G(^PS(59.3,ADA,3)),"^")=1&($P($G(^PS(59.3,ADA,3)),"^",4)'="") D
22 .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
23 D:$G(DWT) WAIT^PSOBGMG1
24 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
25 G:$G(^PS(59.3,ADA,"STOP")) END W @IOF
26 I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
27 S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,!
28 S ZH=$S($G(COLM):1,1:10),ZV=4 S:$G(DWT) ZV=6
29 S NAME="" F S NAME=$O(^PS(52.11,"ANAM",ADA,NAME)) Q:""[NAME!($G(^PS(59.3,ADA,"STOP"))) D
30 .I '$G(COLM) D INDX^PSOBGMG1 I ZV>18 D
31 ..H 20 W @IOF I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
32 ..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
33 .I $G(COLM) D INDX^PSOBGMG1 I ZV>18,ZH>39 D
34 ..H 20 W @IOF I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
35 ..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
36 .I $G(COLM),ZH>39 S ZV=ZV+2,ZH=1
37 .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"))
38 G:$G(^PS(59.3,ADA,"STOP")) END Q:STOP G ANAME
39TICKDV D DEV^PSOBGMG1 W:$G(NODV) !,"No device selected." G END
40TICKET G:$G(^PS(59.3,ADA,"STOP")) END H:ZV 20
41 I $P($G(^PS(59.3,ADA,3)),"^")=1&($P($G(^PS(59.3,ADA,3)),"^",4)'="") D
42 .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
43 D:$G(DWT) WAIT^PSOBGMG1
44 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
45 G:$G(^PS(59.3,ADA,"STOP")) END W @IOF
46 I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
47 S DX=1,DY=1 S:$G(DWT) DY=3 X IOXY W TOP,FTX S DY=DY+1 X IOXY W BOT,FTX,!
48 S ZH=$S($G(COLM):1,1:15),ZV=4 S:$G(DWT) ZV=6
49 S TICK="" F S TICK=$O(^PS(52.11,"ATIC",ADA,TICK)) Q:'TICK!($G(^PS(59.3,ADA,"STOP"))) D
50 .;check for Bad records and kill orphaned xrefs PSO*232
51 .I $$ATICCHK(ADA,TICK) Q
52 .I ZV>20 D
53 ..H 20 W @IOF I $G(DWT) S DX=1,DY=1 X IOXY W TOP,TTX,!?1,BOT,TTX,!
54 ..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
55 .I $G(COLM),ZH>16 S ZV=ZV+2,ZH=1
56 .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
57 G:$G(^PS(59.3,ADA,"STOP")) END I '$G(COLM),ZV<6 H 20
58 I ($G(COLM))&(ZV<6)&(ZH<39) H 20
59 G TICKET
60STOPIT 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
61 I $G(^PS(59.3,ADA,"STOP")) W !!,$C(7),"Board has already been stopped."
62 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
63 S ^PS(59.3,ADA,"STOP")=1,STOP=1 W !!,"Board Stopped!!",!!
64CNT 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
65 I 'CNT1 W !!,"There are no entries to purge from the display group.",! G STOPEX
66 W !!,$C(7),CNT1," entries still remain in the display group.",!
67PRG 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
68 W !!,"Purging data. Please wait."
69 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
70 W " Purge complete!",!
71STOPEX K ADA,AS,CNT,CNT1,DA,DIK,DIRUT,FLAG,STOP,Y Q
72DISP W !! K DIC,DA,DR
73 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
74 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
75 D ^DIE G:'$D(DA) DISP L -^PS(59.3,DA) G:'$D(^PS(59.3,DA,2,0)) DISP G:$G(DIRUT) DISPEX1
76 ;
77 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
78 I $G(EDT) D STRTM^PSOBGMG2 G:'$G(EDT) DISPEX1 D INIJ^PSOBGMG2
79DISPEX1 K EDT,DIE,DIR,DR Q
80 ;
81ATICCHK(DV,TK) ;check ATIC xref if points to non-existent recs, then cleanup
82 ; Return 0 - if no cleanup
83 ; 1 - if had to cleanup
84 ;
85 Q:($G(DV)="")!($G(TK)="") 0
86 N QT,P52 S P52=$O(^PS(52.11,"ATIC",DV,TK,"")),QT=0
87 ;if record pointed to is no longer on file (probably deleted),
88 ;then insure no orphanned xrefs
89 I '$D(^PS(52.11,P52)) D S QT=1
90 . K ^PS(52.11,"ATIC",DV,TK,P52)
91 . K ^PS(52.11,"ANAMK",P52)
92 . K ^PS(52.11,"ANAM",DV,TK,P52)
93 . K ^PS(52.11,"C",TK,P52)
94 . K ^PS(52.11,"AD",DV,P52)
95 . N PA,PAI
96 . S PA="" F S PA=$O(^PS(52.11,"ANAM",DV,PA)) Q:PA="" D
97 . . S PAI="" F S PAI=$O(^PS(52.11,"ANAM",DV,PA,PAI)) Q:PAI="" D
98 . . . I PAI=P52 K ^PS(52.11,"ANAM",DV,PA,PAI)
99 Q QT
100 ;
101TEXT ;display text about setting up dedicated device
102 W !!,"In order to automatically start and stop the bingo board monitor,"
103 W !,"a dedicated device must be setup by your IRM Service.",!!
104 W "Once a dedicated device is setup, the bingo board can be scheduled"
105 W !,"to automatically start and/or stop at user-defined times."
106 W !!,"Enter 'NO' at the DISPLAY SETUP HELP TEXT prompt to not display this help text.",!
107 Q
108 ;
109 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
110 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
111 N LAST F NODE=0:0 S NODE=$O(^PS(59.3,DA,2,NODE)) Q:'NODE S LAST=NODE
112 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
113 G DISP
114DISPEX K ADA,DA,FLAG,LAST,LNODE,NODE,NODE1,^UTILITY($J,"W"),X,Y Q
115ERASE S REC=$O(^PS(52.11,0)) I 'REC W !!,"All data has been purged!" K REC Q
116 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"
117 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
118 S:$G(DGP) DIC("B")=DGP
119 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
120ALL W !!,$C(7),"*** THIS WILL PURGE ALL BINGO BOARD PATIENT DATA FOR ALL DISPLAY GROUPS. ***",!!
121 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
122PUR S DIK="^PS(52.11,",DA=0 F S DA=$O(^PS(52.11,DA)) Q:'DA D ^DIK
123 K DIR,DIK,DA W " Purge complete.",! G ERASE
124END S ZTREQ="@" I $G(ADA)'="" S:$G(^PS(59.3,ADA,"STOP")) STOP=1
125END1 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
126 K %,%ZIS,AWT,AWT1,AWT2,BBH,BBM,DEV,DLAYGO,DTOUT,DV,DWT,DX,DY,EN,IOXY,NTXT,NUM,NWT,POP,TASK,TTX,WTT
127 I $G(STOP) K STOP W @IOF D ^%ZISC G H^XUS
128 K STOP Q
Note: See TracBrowser for help on using the repository browser.