- PSOBING1 ;BHAM ISC/LC - bingo board utility routine ;11/09/17 20:19
- ;;7.0;OUTPATIENT PHARMACY;**5,28,56,135,244,268,357,385,502**;DEC 1997;Build 13
- ;External reference to ^PS(55 supported by DBIA 2228
- ;External reference to DD(52.11 and DD(59.2 supported by DBIA 999
- ;
- ;*244 don't store to file 52.11 if Rx Status > 11
- ;
- BEG Q:'$G(PSODFN) 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 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
- .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)
- .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
- S DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_""
- 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 D STALK G:$G(GRTP)="N" END
- Q
- NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?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",!!
- Q
- STALK I $G(^PS(55,"ASTALK",DFN)) W !!,$C(7),"** ",$P($G(^DPT(DFN,0)),"^")," is enrolled for ScripTalk.",! D
- .N X,Y,PSOSTDEV,PSOSTMAP
- .S (PSOSTMAP,PSOSTDEV)=""
- .S X=$G(PSOLAP) I X]"" S DIC=3.5,DIC(0)="" D ^DIC S PSOSTMAP=+Y
- .I PSOSTMAP D I PSOSTMAP,PSOSTDEV="" Q
- ..N A
- ..S A=$O(^PS(59.7,1,47,"B",PSOSTMAP,"")) I A="" S PSOSTMAP=0 Q
- ..S PSOSTDEV="" D
- ...I A S PSOSTDEV=$P($G(^PS(59.7,1,47,A,0)),"^",2)
- ...I PSOSTDEV="" W !!?5,"Please review ScripTalk mapped device setup.",!!?5,"No ScripTalk label will print.",!!
- .I $P($G(^PS(59,+PSOSITE,"STALK")),"^")="" W !," ** NO SCRIPTALK PRINTER DEFINED FOR THIS DIVISION!" D I 'PSOSTMAP Q
- ..I PSOSTMAP W !?5,"Using Mapped printer",!! Q
- ..W !!?5,"No mapped printer defined. No ScripTalk label will print.",!!
- .I 'PSOSTMAP,$P($G(^PS(59,+PSOSITE,"STALK")),"^",2)="M" W !!?5,"There is no Mapped printer and the Division printer is set for Manual.",!!?5,"You must manually queue the ScripTalk label(s) to print.",! Q
- .W " Please use label(s) from ScripTalk printer." W !
- 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
- I $$STATUS^PSOBPSUT(RXP)]"" D SIGMSG^PSOBINGO
- 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 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBING1 8865 printed Feb 18, 2025@23:51:14 Page 2
- PSOBING1 ;BHAM ISC/LC - bingo board utility routine ;11/09/17 20:19
- +1 ;;7.0;OUTPATIENT PHARMACY;**5,28,56,135,244,268,357,385,502**;DEC 1997;Build 13
- +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 ;
- +5 ;*244 don't store to file 52.11 if Rx Status > 11
- +6 ;
- BEG if '$GET(PSODFN)
- QUIT
- 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 SET GRTP=$PIECE($GET(^PS(59.3,DISGROUP,0)),"^",2)
- SET NAM=$PIECE($GET(^DPT(PSODFN,0)),"^")
- SET SSN=$PIECE($GET(^DPT(PSODFN,0)),"^",9)
- IF GRTP="T"
- Begin DoDot:1
- +1 KILL TFLAG
- SET DR="1;2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$EXTRACT(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_""
- DO STO
- if '$DATA(DA)
- QUIT
- +2 WRITE !!
- SET TIC=$PIECE(^PS(52.11,DA,0),"^",2)
- Begin DoDot:2
- +3 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
- +4 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
- +5 KILL TDFN,TIEN,TSSN
- if 'TFLAG
- QUIT
- End DoDot:2
- End DoDot:1
- if '$DATA(DA)
- GOTO END
- +6 IF $GET(GRTP)="T"
- if 'TFLAG
- GOTO NEW1
- if TFLAG
- GOTO END
- +7 SET DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$EXTRACT(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_""
- 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
- DO STALK
- if $GET(GRTP)="N"
- GOTO END
- +4 QUIT
- NOTE SET DFN=$PIECE($GET(^PS(52.11,DA,0)),"^")
- SET NFLAG=1
- WRITE !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER"
- +1 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
- +2 WRITE !!,"Please advise the patient that the above ID # and/or ORDER Letter"
- +3 WRITE !,"will be displayed with his/her name on the Bingo Display",!!
- +4 QUIT
- STALK IF $GET(^PS(55,"ASTALK",DFN))
- WRITE !!,$CHAR(7),"** ",$PIECE($GET(^DPT(DFN,0)),"^")," is enrolled for ScripTalk.",!
- Begin DoDot:1
- +1 NEW X,Y,PSOSTDEV,PSOSTMAP
- +2 SET (PSOSTMAP,PSOSTDEV)=""
- +3 SET X=$GET(PSOLAP)
- IF X]""
- SET DIC=3.5
- SET DIC(0)=""
- DO ^DIC
- SET PSOSTMAP=+Y
- +4 IF PSOSTMAP
- Begin DoDot:2
- +5 NEW A
- +6 SET A=$ORDER(^PS(59.7,1,47,"B",PSOSTMAP,""))
- IF A=""
- SET PSOSTMAP=0
- QUIT
- +7 SET PSOSTDEV=""
- Begin DoDot:3
- +8 IF A
- SET PSOSTDEV=$PIECE($GET(^PS(59.7,1,47,A,0)),"^",2)
- +9 IF PSOSTDEV=""
- WRITE !!?5,"Please review ScripTalk mapped device setup.",!!?5,"No ScripTalk label will print.",!!
- End DoDot:3
- End DoDot:2
- IF PSOSTMAP
- IF PSOSTDEV=""
- QUIT
- +10 IF $PIECE($GET(^PS(59,+PSOSITE,"STALK")),"^")=""
- WRITE !," ** NO SCRIPTALK PRINTER DEFINED FOR THIS DIVISION!"
- Begin DoDot:2
- +11 IF PSOSTMAP
- WRITE !?5,"Using Mapped printer",!!
- QUIT
- +12 WRITE !!?5,"No mapped printer defined. No ScripTalk label will print.",!!
- End DoDot:2
- IF 'PSOSTMAP
- QUIT
- +13 IF 'PSOSTMAP
- IF $PIECE($GET(^PS(59,+PSOSITE,"STALK")),"^",2)="M"
- WRITE !!?5,"There is no Mapped printer and the Division printer is set for Manual.",!!?5,"You must manually queue the ScripTalk label(s) to print.",!
- QUIT
- +14 WRITE " Please use label(s) from ScripTalk printer."
- WRITE !
- End DoDot:1
- +15 KILL NODE,Z1,Z2,Z3
- +16 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 IF $$STATUS^PSOBPSUT(RXP)]""
- DO SIGMSG^PSOBINGO
- +7 DO REMOVE1^PSOBINGO
- +8 KILL BRX,DIK,DA,XX
- WRITE !!,BNAME," is removed from the display."
- +9 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 SET BNGRXP=RXP
- NEW NAM,NAME,RXO,SSN
- +1 SET NAM=$PIECE($GET(^DPT(BINGNAM,0)),"^")
- SET ADA=""
- SET BNGRXP=RXP
- +2 FOR XX=0:0
- SET XX=$ORDER(^PS(52.11,"B",BINGNAM,XX))
- if 'XX
- QUIT
- Begin DoDot:1
- +3 FOR BRX=0:0
- SET BRX=$ORDER(^PS(52.11,XX,2,"B",BRX))
- if 'BRX
- QUIT
- Begin DoDot:2
- +4 IF BRX=BNGRXP
- SET (DA,ODA)=XX
- End DoDot:2
- End DoDot:1
- +5 IF '$DATA(DA)
- WRITE !!,"The Rx for ",NAM," isn't in the Bingo Board",!,"file and must be entered manually.",$CHAR(7)
- GOTO END
- +6 IF $PIECE($GET(^PS(52.11,DA,0)),"^",7)]""
- WRITE !!,NAM," is already in the display queue.",$CHAR(7)
- GOTO END
- +7 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
- +8 if $PIECE($GET(^PS(52.11,DA,0)),"^",9)
- GOTO REL1
- +9 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
- +10 IF $DATA(BINGRO)
- IF $DATA(BINGDIV)
- SET BDIV=BINGDIV
- GOTO REL1
- +11 IF $DATA(BINGRPR)
- IF $DATA(BNGPDV)
- SET BDIV=BNGPDV
- GOTO REL1
- +12 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
