PSOBING1 ;BHAM ISC/LC - bingo board utility routine ;15-Feb-2013 09:38;PLS
;;7.0;OUTPATIENT PHARMACY;**5,28,56,135,244,268,1015**;DEC 1997;Build 62
;External reference to ^PS(55 supported by DBIA 2228
;External reference to DD(52.11 and DD(59.2 supported by DBIA 999
; Modified - IHS/CIA/PLS - 03/10/04 - Lines NEW1, REL and NOTE
;*244 don't store to file 52.11 if Rx Status > 11
;
BEG D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
NEW K DD,DO S (DIC,DIE)="^PS(52.11,",(NDA,X,DA)=PSODFN,DIC(0)="LMNQZ" D FILE^DICN K DIC G:Y'>0 NEW S (ODA,DA)=+Y,BNGSUS=0 S:$D(SUSROUTE) BNGSUS=1
NEW1 ; IHS/CIA/PLS - 07/08/04 - Change SSN references to HRN
;S GRTP=$P($G(^PS(59.3,DISGROUP,0)),"^",2),NAM=$P($G(^DPT(PSODFN,0)),"^"),SSN=$P($G(^DPT(PSODFN,0)),"^",9) I GRTP="T" D G:'$D(DA) END
S GRTP=$P($G(^PS(59.3,DISGROUP,0)),"^",2),NAM=$P($G(^DPT(PSODFN,0)),"^"),SSN=$$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,PSOSITE,100,"I")) I GRTP="T" D G:'$D(DA) END
.; IHS/CIA/PLS - 08/18/04 - Added TIME READY field
.;K TFLAG S DR="1;2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_"" D STO Q:'$D(DA)
.K TFLAG S DR="1;2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_";6////"_$E(TM1_"0000",1,4)_"" D STO Q:'$D(DA)
.W !! S TIC=$P(^PS(52.11,DA,0),"^",2) D
..F TIEN=0:0 S TIEN=$O(^PS(52.11,"C",TIC,TIEN)) Q:'TIEN I DA'=TIEN,($P(^PS(52.11,DA,0),"^",4)=+$P(^PS(52.11,TIEN,0),"^",4)) D
...S TDFN=$P(^PS(52.11,TIEN,0),"^"),TSSN=$P(^PS(52.11,TIEN,1),"^",2),TFLAG=0 W !,$C(7),$P(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",!
..K TDFN,TIEN,TSSN Q:'TFLAG
I $G(GRTP)="T" G:'TFLAG NEW1 G:TFLAG END
; IHS/CIA/PLS - 08/18/04 - Added TIME READY field
;S DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_""
S DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_";6////"_$E(TM1_"0000",1,4)_""
STO S NFLAG=1 L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),Y(0,0)," is being edited!",! S DA=NDA D WARN Q:$G(GRTP)="T" G END
S XDA=DA D ^DIE I $G(DUOUT)!($G(DTOUT))!(X="") S DA=ODA D WARN G END
S DA=XDA D STORX S DA=XDA L -^PS(52.11,DA)
S TFLAG=1 D:$G(GRTP)="N" CHKUP^PSOBINGO,NOTE G:$G(GRTP)="N" END
Q
NOTE ; IHS/CIA/PLS - 07/08/04 - Changed SSN reference to HRN
;S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER"
S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"HRN",?45,"ID",?50,"ORDER"
F Z=0:0 S Z=$O(^PS(52.11,"B",DFN,Z)) Q:'Z S ZDA=Z S NODE=^PS(52.11,ZDA,1),Z1=$P($G(NODE),"^"),Z2=$P($G(NODE),"^",3),Z3=$P($G(NODE),"^",4),Z4=$P($G(NODE),"^",2) W !,?5,Z1,?30,Z4,?46,Z2,?52,Z3
W !!,"Please advise the patient that the above ID # and/or ORDER Letter"
W !,"will be displayed with his/her name on the Bingo Display",!!
I $G(^PS(55,"ASTALK",DFN)) W !,$C(7),"** ",Z1," is enrolled for ScripTalk.",!," Please use label(s) from ScripTalk printer." D W !
.I $P($G(^PS(59,+PSOSITE,"STALK")),"^")="" W !," ** NO SCRIPTALK PRINTER DEFINED FOR THIS DIVISION!",! Q
.I $P($G(^PS(59,+PSOSITE,"STALK")),"^",2)'="A" W !," ** SCRIPTALK PRINTER IS NOT DEFINED FOR AUTO-PRINT",!,"You must manually queue the ScripTalk label(s) to print.",!
K NODE,Z1,Z2,Z3
Q
HELP W !!,"Wand the barcode of the Rx or manually key in",!,"the number below the barcode, the Rx number, or the",!,"patient name in the format - 'LASTNAME,FIRSTNAME'"
W !!,"The barcode # should be of the format - 'NNN-NNNNNNN'"
Q
BCRMV W !! K DIR S DIR("A")="Enter/Wand Rx # or Enter PATIENT NAME",DIR("?")="^D HELP^PSOBING1",DIR(0)="FO^1:45" D ^DIR
G:$D(DIRUT) END
I X'["-" D BCI^PSODISP Q:'$G(RXP) G BCRMV1
I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7)," INVALID STATION # !",! G BCRMV
I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7)," NON-EXISTENT RX #" G BCRMV
G:$D(^PSRX(RXP,0)) BCRMV1
W !?7,$C(7)," IMPROPER BARCODE FORMAT" G BCRMV
BCRMV1 S NME=$P($G(^PSRX(RXP,0)),"^",2),BNAME=$P($G(^DPT(NME,0)),"^"),BDA="",CNT1=0
F XX=0:0 S XX=$O(^PS(52.11,"B",NME,XX)) Q:'XX D
.F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX D
..I BRX=RXP S DA=XX
I '$D(DA) W !!,BNAME," isn't in the Bingo Board file.",$C(7) G BCRMV
I $D(^PS(52.11,"ANAMK",DA)) W !!,BNAME," has already been removed from the display.",$C(7) G BCRMV
D REMOVE1^PSOBINGO
K BRX,DIK,DA,XX W !!,BNAME," is removed from the display."
G BCRMV
WARN W !!,$C(7),"Bingo record is incomplete!" S DIK="^PS(52.11," D ^DIK K DIK,DA W !!,"Bingo record removed.",!
Q
STORX ;Sto Rx # for each entry in 52.11
Q:'$D(BBRX(1)) N DIC,DIE,NUM,BB,BBN,DR,FL,FLN,I
S DA(1)=DA,(DIC,DIE)="^PS(52.11,"_DA(1)_",2,",DIC(0)="L",DIC("P")=$P(^DD(52.11,12,0),"^",2),DLAYGO=52.11
F BBN=0:0 S BBN=$O(BBRX(BBN)) Q:'BBN F NUM=1:1 S BB=$P(BBRX(BBN),",",NUM) Q:'BB D
.Q:$G(^PSRX(BB,"STA"))>11 ;*244
.I $D(RXPR(BB)) S FL="P",FLN=$G(RXPR(BB))
.I '$D(RXPR(BB)) F I=0:0 S I=$O(^PSRX(BB,1,I)) Q:'I S FL="F",FLN=I
.I '$D(FL) S FL="F",FLN=0
.S X=$P(^PSRX(BB,0),"^") D ^DIC
.S DA=$P(Y,"^"),DR="1////"_FL_";2////"_FLN_"" D ^DIE K FL,FLN
Q
;
WTIME ;sto bingo wait time in 52
Q:'$D(DA)!'$D(DIF) S BDA=DA
N DIE,XX,BRX1,BRXFL,BRXFLN,DR
S DA(1)=DA,DIE="^PS(52.11,"_DA(1)_",2,"
F XX=0:0 S XX=$O(^PS(52.11,BDA,2,XX)) Q:'XX S DA=XX,BRX=$G(^PS(52.11,BDA,2,DA,0)),BRX1=$P(^(0),"^"),BRXFL=$P(^(0),"^",2),BRXFLN=$P(^(0),"^",3) D
.S DR="3////"_DIF_"" D ^DIE D
..N DA,DIE S DA=BRX1
..I $G(BRXFLN)=0 S DIE="^PSRX(",DR="32.3////"_DIF_"" D ^DIE K DIE
..I $G(BRXFLN)>0,$G(BRXFL)="F",$G(^PSRX(DA,1,BRXFLN,0)) S DA(1)=DA,DIE="^PSRX("_DA(1)_",1,",DA=BRXFLN,DR="18////"_DIF_"" D ^DIE K DIE
..I $G(BRXFLN)>0,$G(BRXFL)="P",$G(^PSRX(DA,"P",BRXFLN,0)) S DA(1)=DA,DIE="^PSRX("_DA(1)_",""P"",",DA=BRXFLN,DR="9////"_DIF_"" D ^DIE K DIE
S DA=BDA K DIE,XX,BRX,BRX1,BRXFL,BRXFLN,DR,DA(1)
Q
;
CREF ;check for deleted refills
S BDA=DA,XX=0,BRB="" F S XX=$O(^PS(52.11,BDA,2,XX)) Q:'XX S DA=XX D
.S BRX0=$G(^PS(52.11,BDA,2,DA,0)),BRX1=$P(BRX0,"^"),BRXFL=$P(BRX0,"^",2),BRXFLN=$P(BRX0,"^",3)
.I BRXFLN,BRXFL="F",$G(^PSRX(BRX1,1,BRXFLN,0))']"" D
..S DA(1)=BDA,DIK="^PS(52.11,"_DA(1)_",2," D ^DIK K DIK,DA(1)
..S BRB=BRB_$S(BRB="":"",1:"; ")_BRX1_","_BRXFLN
S DA=BDA I BRB]"",$P($G(^PS(52.11,BDA,2,0)),"^",4)=0 D
.W !!,$C(7),"Refill(s) "_BRB_" does not exist.",!,"It can't be displayed and is now deleted."
.S DIK="^PS(52.11," D ^DIK S PSODRF=1
K BDA,BRB,BRX0,BRX1,BRXFL,BRXFLN
Q
;
REL Q:$$GET1^DIQ(9009033,+PSOSITE,314,"I") ; IHS/CIA/PLS - 03/10/04 - Exit if autorelease enabled
S BNGRXP=RXP N NAM,NAME,RXO,SSN
S NAM=$P($G(^DPT(BINGNAM,0)),"^"),ADA="",BNGRXP=RXP
F XX=0:0 S XX=$O(^PS(52.11,"B",BINGNAM,XX)) Q:'XX D
.F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX D
..I BRX=BNGRXP S (DA,ODA)=XX
I '$D(DA) W !!,"The Rx for ",NAM," isn't in the Bingo Board",!,"file and must be entered manually.",$C(7) G END
I $P($G(^PS(52.11,DA,0)),"^",7)]"" W !!,NAM," is already in the display queue.",$C(7) G END
I $P($P($G(^PS(52.11,DA,0)),"^",5),".")'=DT S Y=$P($P($G(^PS(52.11,DA,0)),"^",5),".") D DD^%DT W !!,$C(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted." S DIK="^PS(52.11," D ^DIK K DIK G END
G:$P($G(^PS(52.11,DA,0)),"^",9) REL1
I $P($G(^PS(52.11,DA,0)),"^",4)'=PSOSITE W !!,NAM," is from another division",!,"and must be displayed manually.",$C(7) G END
I $D(BINGRO),$D(BINGDIV) S BDIV=BINGDIV G REL1
I $D(BINGRPR),$D(BNGPDV) S BDIV=BNGPDV G REL1
I $D(BINGRPR),$D(BNGRDV) S BDIV=BNGRDV G REL1
REL1 N TM,TM1 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
S NM=$P(^DPT($P(^PS(52.11,DA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"",DIE="^PS(52.11,"
L +^PS(52.11,DA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) E W !!,$C(7),NM," is being edited!",! D WARN G END
D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G END
S RX0=^PS(52.11,DA,0),JOES=$P(RX0,"^",4),TICK=+$P($G(RX0),"^",2),GRP=$P($G(^PS(59.3,$P($G(^PS(52.11,DA,0)),"^",3),0)),"^",2) D:GRP="T"&('$G(TICK)) WARN G:'$D(DA) END
W !!,NAM," added to the "_$P($G(^PS(59.3,$P(RX0,"^",3),0)),"^")_" display."
I +$G(^PS(55,"ASTALK",$P(^PS(52.11,DA,0),"^"))) W !,$C(7),"This patient is enrolled in ScripTalk and may benefit from",!,"a non-visual announcement that prescriptions are ready."
S PSZ=0 I '$D(^PS(59.2,DT,0)) K DD,DIC,DO,DA S X=DT,DIC="^PS(59.2,",DIC(0)="",DINUM=X D FILE^DICN S PSZ=1 Q:Y'>0
I PSZ=1 S DA(1)=+Y,DIC=DIC_DA(1)_",1,",(DINUM,X)=JOES,DIC(0)="",DIC("P")=$P(^DD(59.2,1,0),"^",2) K DD,DO D FILE^DICN K DIC,DA Q:Y'>0
I PSZ=0 K DD,DIC,DO,DA S DA(1)=DT,(DINUM,X)=JOES,DIC="^PS(59.2,"_DT_",1,",DIC(0)="LZ" D FILE^DICN K DIC,DA,DO
S DA=ODA D STATS1^PSOBRPRT,WTIME
END K ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES
K NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX
Q
PSOBING1 ;BHAM ISC/LC - bingo board utility routine ;15-Feb-2013 09:38;PLS
+1 ;;7.0;OUTPATIENT PHARMACY;**5,28,56,135,244,268,1015**;DEC 1997;Build 62
+2 ;External reference to ^PS(55 supported by DBIA 2228
+3 ;External reference to DD(52.11 and DD(59.2 supported by DBIA 999
+4 ; Modified - IHS/CIA/PLS - 03/10/04 - Lines NEW1, REL and NOTE
+5 ;*244 don't store to file 52.11 if Rx Status > 11
+6 ;
BEG IF '$DATA(PSOPAR)
DO ^PSOLSET
IF '$DATA(PSOPAR)
GOTO END
NEW KILL DD,DO
SET (DIC,DIE)="^PS(52.11,"
SET (NDA,X,DA)=PSODFN
SET DIC(0)="LMNQZ"
DO FILE^DICN
KILL DIC
IF Y'>0
GOTO NEW
SET (ODA,DA)=+Y
SET BNGSUS=0
IF $DATA(SUSROUTE)
SET BNGSUS=1
NEW1 ; IHS/CIA/PLS - 07/08/04 - Change SSN references to HRN
+1 ;S GRTP=$P($G(^PS(59.3,DISGROUP,0)),"^",2),NAM=$P($G(^DPT(PSODFN,0)),"^"),SSN=$P($G(^DPT(PSODFN,0)),"^",9) I GRTP="T" D G:'$D(DA) END
+2 SET GRTP=$PIECE($GET(^PS(59.3,DISGROUP,0)),"^",2)
SET NAM=$PIECE($GET(^DPT(PSODFN,0)),"^")
SET SSN=$$HRN^AUPNPAT(DFN,$$GET1^DIQ(59,PSOSITE,100,"I"))
IF GRTP="T"
Begin DoDot:1
+3 ; IHS/CIA/PLS - 08/18/04 - Added TIME READY field
+4 ;K TFLAG S DR="1;2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_"" D STO Q:'$D(DA)
+5 KILL TFLAG
SET DR="1;2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$EXTRACT(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_";6////"_$EXTRACT(TM1_"0000",1,4)_""
DO STO
IF '$DATA(DA)
QUIT
+6 WRITE !!
SET TIC=$PIECE(^PS(52.11,DA,0),"^",2)
Begin DoDot:2
+7 FOR TIEN=0:0
SET TIEN=$ORDER(^PS(52.11,"C",TIC,TIEN))
IF 'TIEN
QUIT
IF DA'=TIEN
IF ($PIECE(^PS(52.11,DA,0),"^",4)=+$PIECE(^PS(52.11,TIEN,0),"^",4))
Begin DoDot:3
+8 SET TDFN=$PIECE(^PS(52.11,TIEN,0),"^")
SET TSSN=$PIECE(^PS(52.11,TIEN,1),"^",2)
SET TFLAG=0
WRITE !,$CHAR(7),$PIECE(^DPT(TDFN,0),"^")_" ("_TSSN_") was issued ticket # "_TIC,". Try again!",!
End DoDot:3
+9 KILL TDFN,TIEN,TSSN
IF 'TFLAG
QUIT
End DoDot:2
End DoDot:1
IF '$DATA(DA)
GOTO END
+10 IF $GET(GRTP)="T"
IF 'TFLAG
GOTO NEW1
IF TFLAG
GOTO END
+11 ; IHS/CIA/PLS - 08/18/04 - Added TIME READY field
+12 ;S DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_""
+13 SET DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$EXTRACT(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_";6////"_$EXTRACT(TM1_"0000",1,4)_""
STO SET NFLAG=1
LOCK +^PS(52.11,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !!,$CHAR(7),Y(0,0)," is being edited!",!
SET DA=NDA
DO WARN
IF $GET(GRTP)="T"
QUIT
GOTO END
+1 SET XDA=DA
DO ^DIE
IF $GET(DUOUT)!($GET(DTOUT))!(X="")
SET DA=ODA
DO WARN
GOTO END
+2 SET DA=XDA
DO STORX
SET DA=XDA
LOCK -^PS(52.11,DA)
+3 SET TFLAG=1
IF $GET(GRTP)="N"
DO CHKUP^PSOBINGO
DO NOTE
IF $GET(GRTP)="N"
GOTO END
+4 QUIT
NOTE ; IHS/CIA/PLS - 07/08/04 - Changed SSN reference to HRN
+1 ;S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER"
+2 SET DFN=$PIECE($GET(^PS(52.11,DA,0)),"^")
SET NFLAG=1
WRITE !!,?5,"NAME",?30,"HRN",?45,"ID",?50,"ORDER"
+3 FOR Z=0:0
SET Z=$ORDER(^PS(52.11,"B",DFN,Z))
IF 'Z
QUIT
SET ZDA=Z
SET NODE=^PS(52.11,ZDA,1)
SET Z1=$PIECE($GET(NODE),"^")
SET Z2=$PIECE($GET(NODE),"^",3)
SET Z3=$PIECE($GET(NODE),"^",4)
SET Z4=$PIECE($GET(NODE),"^",2)
WRITE !,?5,Z1,?30,Z4,?46,Z2,?52,Z3
+4 WRITE !!,"Please advise the patient that the above ID # and/or ORDER Letter"
+5 WRITE !,"will be displayed with his/her name on the Bingo Display",!!
+6 IF $GET(^PS(55,"ASTALK",DFN))
WRITE !,$CHAR(7),"** ",Z1," is enrolled for ScripTalk.",!," Please use label(s) from ScripTalk printer."
Begin DoDot:1
+7 IF $PIECE($GET(^PS(59,+PSOSITE,"STALK")),"^")=""
WRITE !," ** NO SCRIPTALK PRINTER DEFINED FOR THIS DIVISION!",!
QUIT
+8 IF $PIECE($GET(^PS(59,+PSOSITE,"STALK")),"^",2)'="A"
WRITE !," ** SCRIPTALK PRINTER IS NOT DEFINED FOR AUTO-PRINT",!,"You must manually queue the ScripTalk label(s) to print.",!
End DoDot:1
WRITE !
+9 KILL NODE,Z1,Z2,Z3
+10 QUIT
HELP WRITE !!,"Wand the barcode of the Rx or manually key in",!,"the number below the barcode, the Rx number, or the",!,"patient name in the format - 'LASTNAME,FIRSTNAME'"
+1 WRITE !!,"The barcode # should be of the format - 'NNN-NNNNNNN'"
+2 QUIT
BCRMV WRITE !!
KILL DIR
SET DIR("A")="Enter/Wand Rx # or Enter PATIENT NAME"
SET DIR("?")="^D HELP^PSOBING1"
SET DIR(0)="FO^1:45"
DO ^DIR
+1 IF $DATA(DIRUT)
GOTO END
+2 IF X'["-"
DO BCI^PSODISP
IF '$GET(RXP)
QUIT
GOTO BCRMV1
+3 IF X["-"
IF $PIECE(X,"-")'=$PIECE($$SITE^VASITE(),"^",3)
WRITE !?7,$CHAR(7)," INVALID STATION # !",!
GOTO BCRMV
+4 IF X["-"
SET RXP=$PIECE(X,"-",2)
IF '$DATA(^PSRX(+$GET(RXP),0))!($GET(RXP)']"")
WRITE !?7,$CHAR(7)," NON-EXISTENT RX #"
GOTO BCRMV
+5 IF $DATA(^PSRX(RXP,0))
GOTO BCRMV1
+6 WRITE !?7,$CHAR(7)," IMPROPER BARCODE FORMAT"
GOTO BCRMV
BCRMV1 SET NME=$PIECE($GET(^PSRX(RXP,0)),"^",2)
SET BNAME=$PIECE($GET(^DPT(NME,0)),"^")
SET BDA=""
SET CNT1=0
+1 FOR XX=0:0
SET XX=$ORDER(^PS(52.11,"B",NME,XX))
IF 'XX
QUIT
Begin DoDot:1
+2 FOR BRX=0:0
SET BRX=$ORDER(^PS(52.11,XX,2,"B",BRX))
IF 'BRX
QUIT
Begin DoDot:2
+3 IF BRX=RXP
SET DA=XX
End DoDot:2
End DoDot:1
+4 IF '$DATA(DA)
WRITE !!,BNAME," isn't in the Bingo Board file.",$CHAR(7)
GOTO BCRMV
+5 IF $DATA(^PS(52.11,"ANAMK",DA))
WRITE !!,BNAME," has already been removed from the display.",$CHAR(7)
GOTO BCRMV
+6 DO REMOVE1^PSOBINGO
+7 KILL BRX,DIK,DA,XX
WRITE !!,BNAME," is removed from the display."
+8 GOTO BCRMV
WARN WRITE !!,$CHAR(7),"Bingo record is incomplete!"
SET DIK="^PS(52.11,"
DO ^DIK
KILL DIK,DA
WRITE !!,"Bingo record removed.",!
+1 QUIT
STORX ;Sto Rx # for each entry in 52.11
+1 IF '$DATA(BBRX(1))
QUIT
NEW DIC,DIE,NUM,BB,BBN,DR,FL,FLN,I
+2 SET DA(1)=DA
SET (DIC,DIE)="^PS(52.11,"_DA(1)_",2,"
SET DIC(0)="L"
SET DIC("P")=$PIECE(^DD(52.11,12,0),"^",2)
SET DLAYGO=52.11
+3 FOR BBN=0:0
SET BBN=$ORDER(BBRX(BBN))
IF 'BBN
QUIT
FOR NUM=1:1
SET BB=$PIECE(BBRX(BBN),",",NUM)
IF 'BB
QUIT
Begin DoDot:1
+4 ;*244
IF $GET(^PSRX(BB,"STA"))>11
QUIT
+5 IF $DATA(RXPR(BB))
SET FL="P"
SET FLN=$GET(RXPR(BB))
+6 IF '$DATA(RXPR(BB))
FOR I=0:0
SET I=$ORDER(^PSRX(BB,1,I))
IF 'I
QUIT
SET FL="F"
SET FLN=I
+7 IF '$DATA(FL)
SET FL="F"
SET FLN=0
+8 SET X=$PIECE(^PSRX(BB,0),"^")
DO ^DIC
+9 SET DA=$PIECE(Y,"^")
SET DR="1////"_FL_";2////"_FLN_""
DO ^DIE
KILL FL,FLN
End DoDot:1
+10 QUIT
+11 ;
WTIME ;sto bingo wait time in 52
+1 IF '$DATA(DA)!'$DATA(DIF)
QUIT
SET BDA=DA
+2 NEW DIE,XX,BRX1,BRXFL,BRXFLN,DR
+3 SET DA(1)=DA
SET DIE="^PS(52.11,"_DA(1)_",2,"
+4 FOR XX=0:0
SET XX=$ORDER(^PS(52.11,BDA,2,XX))
IF 'XX
QUIT
SET DA=XX
SET BRX=$GET(^PS(52.11,BDA,2,DA,0))
SET BRX1=$PIECE(^(0),"^")
SET BRXFL=$PIECE(^(0),"^",2)
SET BRXFLN=$PIECE(^(0),"^",3)
Begin DoDot:1
+5 SET DR="3////"_DIF_""
DO ^DIE
Begin DoDot:2
+6 NEW DA,DIE
SET DA=BRX1
+7 IF $GET(BRXFLN)=0
SET DIE="^PSRX("
SET DR="32.3////"_DIF_""
DO ^DIE
KILL DIE
+8 IF $GET(BRXFLN)>0
IF $GET(BRXFL)="F"
IF $GET(^PSRX(DA,1,BRXFLN,0))
SET DA(1)=DA
SET DIE="^PSRX("_DA(1)_",1,"
SET DA=BRXFLN
SET DR="18////"_DIF_""
DO ^DIE
KILL DIE
+9 IF $GET(BRXFLN)>0
IF $GET(BRXFL)="P"
IF $GET(^PSRX(DA,"P",BRXFLN,0))
SET DA(1)=DA
SET DIE="^PSRX("_DA(1)_",""P"","
SET DA=BRXFLN
SET DR="9////"_DIF_""
DO ^DIE
KILL DIE
End DoDot:2
End DoDot:1
+10 SET DA=BDA
KILL DIE,XX,BRX,BRX1,BRXFL,BRXFLN,DR,DA(1)
+11 QUIT
+12 ;
CREF ;check for deleted refills
+1 SET BDA=DA
SET XX=0
SET BRB=""
FOR
SET XX=$ORDER(^PS(52.11,BDA,2,XX))
IF 'XX
QUIT
SET DA=XX
Begin DoDot:1
+2 SET BRX0=$GET(^PS(52.11,BDA,2,DA,0))
SET BRX1=$PIECE(BRX0,"^")
SET BRXFL=$PIECE(BRX0,"^",2)
SET BRXFLN=$PIECE(BRX0,"^",3)
+3 IF BRXFLN
IF BRXFL="F"
IF $GET(^PSRX(BRX1,1,BRXFLN,0))']""
Begin DoDot:2
+4 SET DA(1)=BDA
SET DIK="^PS(52.11,"_DA(1)_",2,"
DO ^DIK
KILL DIK,DA(1)
+5 SET BRB=BRB_$SELECT(BRB="":"",1:"; ")_BRX1_","_BRXFLN
End DoDot:2
End DoDot:1
+6 SET DA=BDA
IF BRB]""
IF $PIECE($GET(^PS(52.11,BDA,2,0)),"^",4)=0
Begin DoDot:1
+7 WRITE !!,$CHAR(7),"Refill(s) "_BRB_" does not exist.",!,"It can't be displayed and is now deleted."
+8 SET DIK="^PS(52.11,"
DO ^DIK
SET PSODRF=1
End DoDot:1
+9 KILL BDA,BRB,BRX0,BRX1,BRXFL,BRXFLN
+10 QUIT
+11 ;
REL ; IHS/CIA/PLS - 03/10/04 - Exit if autorelease enabled
IF $$GET1^DIQ(9009033,+PSOSITE,314,"I")
QUIT
+1 SET BNGRXP=RXP
NEW NAM,NAME,RXO,SSN
+2 SET NAM=$PIECE($GET(^DPT(BINGNAM,0)),"^")
SET ADA=""
SET BNGRXP=RXP
+3 FOR XX=0:0
SET XX=$ORDER(^PS(52.11,"B",BINGNAM,XX))
IF 'XX
QUIT
Begin DoDot:1
+4 FOR BRX=0:0
SET BRX=$ORDER(^PS(52.11,XX,2,"B",BRX))
IF 'BRX
QUIT
Begin DoDot:2
+5 IF BRX=BNGRXP
SET (DA,ODA)=XX
End DoDot:2
End DoDot:1
+6 IF '$DATA(DA)
WRITE !!,"The Rx for ",NAM," isn't in the Bingo Board",!,"file and must be entered manually.",$CHAR(7)
GOTO END
+7 IF $PIECE($GET(^PS(52.11,DA,0)),"^",7)]""
WRITE !!,NAM," is already in the display queue.",$CHAR(7)
GOTO END
+8 IF $PIECE($PIECE($GET(^PS(52.11,DA,0)),"^",5),".")'=DT
SET Y=$PIECE($PIECE($GET(^PS(52.11,DA,0)),"^",5),".")
DO DD^%DT
WRITE !!,$CHAR(7),NAM," was entered on "_Y_".",!,"It can't be displayed and is now deleted."
SET DIK="^PS(52.11,"
DO ^DIK
KILL DIK
GOTO END
+9 IF $PIECE($GET(^PS(52.11,DA,0)),"^",9)
GOTO REL1
+10 IF $PIECE($GET(^PS(52.11,DA,0)),"^",4)'=PSOSITE
WRITE !!,NAM," is from another division",!,"and must be displayed manually.",$CHAR(7)
GOTO END
+11 IF $DATA(BINGRO)
IF $DATA(BINGDIV)
SET BDIV=BINGDIV
GOTO REL1
+12 IF $DATA(BINGRPR)
IF $DATA(BNGPDV)
SET BDIV=BNGPDV
GOTO REL1
+13 IF $DATA(BINGRPR)
IF $DATA(BNGRDV)
SET BDIV=BNGRDV
GOTO REL1
REL1 NEW TM,TM1
DO NOW^%DTC
SET TM=$EXTRACT(%,1,12)
SET TM1=$PIECE(TM,".",2)
+1 SET NM=$PIECE(^DPT($PIECE(^PS(52.11,DA,0),"^"),0),"^")
SET DR="6////"_$EXTRACT(TM1_"0000",1,4)_";8////"_NM_""
SET DIE="^PS(52.11,"
+2 LOCK +^PS(52.11,DA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !!,$CHAR(7),NM," is being edited!",!
DO WARN
GOTO END
+3 DO ^DIE
LOCK -^PS(52.11,DA)
IF $GET(DUOUT)!($GET(DTOUT))!(X="")
DO WARN
GOTO END
+4 SET RX0=^PS(52.11,DA,0)
SET JOES=$PIECE(RX0,"^",4)
SET TICK=+$PIECE($GET(RX0),"^",2)
SET GRP=$PIECE($GET(^PS(59.3,$PIECE($GET(^PS(52.11,DA,0)),"^",3),0)),"^",2)
IF GRP="T"&('$GET(TICK))
DO WARN
IF '$DATA(DA)
GOTO END
+5 WRITE !!,NAM," added to the "_$PIECE($GET(^PS(59.3,$PIECE(RX0,"^",3),0)),"^")_" display."
+6 IF +$GET(^PS(55,"ASTALK",$PIECE(^PS(52.11,DA,0),"^")))
WRITE !,$CHAR(7),"This patient is enrolled in ScripTalk and may benefit from",!,"a non-visual announcement that prescriptions are ready."
+7 SET PSZ=0
IF '$DATA(^PS(59.2,DT,0))
KILL DD,DIC,DO,DA
SET X=DT
SET DIC="^PS(59.2,"
SET DIC(0)=""
SET DINUM=X
DO FILE^DICN
SET PSZ=1
IF Y'>0
QUIT
+8 IF PSZ=1
SET DA(1)=+Y
SET DIC=DIC_DA(1)_",1,"
SET (DINUM,X)=JOES
SET DIC(0)=""
SET DIC("P")=$PIECE(^DD(59.2,1,0),"^",2)
KILL DD,DO
DO FILE^DICN
KILL DIC,DA
IF Y'>0
QUIT
+9 IF PSZ=0
KILL DD,DIC,DO,DA
SET DA(1)=DT
SET (DINUM,X)=JOES
SET DIC="^PS(59.2,"_DT_",1,"
SET DIC(0)="LZ"
DO FILE^DICN
KILL DIC,DA,DO
+10 SET DA=ODA
DO STATS1^PSOBRPRT
DO WTIME
END KILL ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES
+1 KILL NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX
+2 QUIT
