source: FOIAVistA/tag/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOBING1.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 7.8 KB
Line 
1PSOBING1 ;BHAM ISC/LC - bingo board utility routine ;6/29/06 11:46am
2 ;;7.0;OUTPATIENT PHARMACY;**5,28,56,135,244,268**;DEC 1997;Build 9
3 ;External reference to ^PS(55 supported by DBIA 2228
4 ;External reference to DD(52.11 and DD(59.2 supported by DBIA 999
5 ;
6 ;*244 don't store to file 52.11 if Rx Status > 11
7 ;
8BEG D:'$D(PSOPAR) ^PSOLSET G:'$D(PSOPAR) END
9NEW 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
10NEW1 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
11 .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)
12 .W !! S TIC=$P(^PS(52.11,DA,0),"^",2) D
13 ..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
14 ...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!",!
15 ..K TDFN,TIEN,TSSN Q:'TFLAG
16 I $G(GRTP)="T" G:'TFLAG NEW1 G:TFLAG END
17 S DR="2////"_DISGROUP_";3////"_PSOSITE_";4////"_TM_";5////"_$E(TM1_"0000",1,4)_";8////"_NAM_";9////"_SSN_";13////"_BNGSUS_""
18STO 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
19 S XDA=DA D ^DIE I $G(DUOUT)!($G(DTOUT))!(X="") S DA=ODA D WARN G END
20 S DA=XDA D STORX S DA=XDA L -^PS(52.11,DA)
21 S TFLAG=1 D:$G(GRTP)="N" CHKUP^PSOBINGO,NOTE G:$G(GRTP)="N" END
22 Q
23NOTE S DFN=$P($G(^PS(52.11,DA,0)),"^"),NFLAG=1 W !!,?5,"NAME",?30,"SSN",?45,"ID",?50,"ORDER"
24 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
25 W !!,"Please advise the patient that the above ID # and/or ORDER Letter"
26 W !,"will be displayed with his/her name on the Bingo Display",!!
27 I $G(^PS(55,"ASTALK",DFN)) W !,$C(7),"** ",Z1," is enrolled for ScripTalk.",!," Please use label(s) from ScripTalk printer." D W !
28 .I $P($G(^PS(59,+PSOSITE,"STALK")),"^")="" W !," ** NO SCRIPTALK PRINTER DEFINED FOR THIS DIVISION!",! Q
29 .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.",!
30 K NODE,Z1,Z2,Z3
31 Q
32HELP 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'"
33 W !!,"The barcode # should be of the format - 'NNN-NNNNNNN'"
34 Q
35BCRMV W !! K DIR S DIR("A")="Enter/Wand Rx # or Enter PATIENT NAME",DIR("?")="^D HELP^PSOBING1",DIR(0)="FO^1:45" D ^DIR
36 G:$D(DIRUT) END
37 I X'["-" D BCI^PSODISP Q:'$G(RXP) G BCRMV1
38 I X["-",$P(X,"-")'=$P($$SITE^VASITE(),"^",3) W !?7,$C(7)," INVALID STATION # !",! G BCRMV
39 I X["-" S RXP=$P(X,"-",2) I '$D(^PSRX(+$G(RXP),0))!($G(RXP)']"") W !?7,$C(7)," NON-EXISTENT RX #" G BCRMV
40 G:$D(^PSRX(RXP,0)) BCRMV1
41 W !?7,$C(7)," IMPROPER BARCODE FORMAT" G BCRMV
42BCRMV1 S NME=$P($G(^PSRX(RXP,0)),"^",2),BNAME=$P($G(^DPT(NME,0)),"^"),BDA="",CNT1=0
43 F XX=0:0 S XX=$O(^PS(52.11,"B",NME,XX)) Q:'XX D
44 .F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX D
45 ..I BRX=RXP S DA=XX
46 I '$D(DA) W !!,BNAME," isn't in the Bingo Board file.",$C(7) G BCRMV
47 I $D(^PS(52.11,"ANAMK",DA)) W !!,BNAME," has already been removed from the display.",$C(7) G BCRMV
48 D REMOVE1^PSOBINGO
49 K BRX,DIK,DA,XX W !!,BNAME," is removed from the display."
50 G BCRMV
51WARN W !!,$C(7),"Bingo record is incomplete!" S DIK="^PS(52.11," D ^DIK K DIK,DA W !!,"Bingo record removed.",!
52 Q
53STORX ;Sto Rx # for each entry in 52.11
54 Q:'$D(BBRX(1)) N DIC,DIE,NUM,BB,BBN,DR,FL,FLN,I
55 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
56 F BBN=0:0 S BBN=$O(BBRX(BBN)) Q:'BBN F NUM=1:1 S BB=$P(BBRX(BBN),",",NUM) Q:'BB D
57 .Q:$G(^PSRX(BB,"STA"))>11 ;*244
58 .I $D(RXPR(BB)) S FL="P",FLN=$G(RXPR(BB))
59 .I '$D(RXPR(BB)) F I=0:0 S I=$O(^PSRX(BB,1,I)) Q:'I S FL="F",FLN=I
60 .I '$D(FL) S FL="F",FLN=0
61 .S X=$P(^PSRX(BB,0),"^") D ^DIC
62 .S DA=$P(Y,"^"),DR="1////"_FL_";2////"_FLN_"" D ^DIE K FL,FLN
63 Q
64 ;
65WTIME ;sto bingo wait time in 52
66 Q:'$D(DA)!'$D(DIF) S BDA=DA
67 N DIE,XX,BRX1,BRXFL,BRXFLN,DR
68 S DA(1)=DA,DIE="^PS(52.11,"_DA(1)_",2,"
69 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
70 .S DR="3////"_DIF_"" D ^DIE D
71 ..N DA,DIE S DA=BRX1
72 ..I $G(BRXFLN)=0 S DIE="^PSRX(",DR="32.3////"_DIF_"" D ^DIE K DIE
73 ..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
74 ..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
75 S DA=BDA K DIE,XX,BRX,BRX1,BRXFL,BRXFLN,DR,DA(1)
76 Q
77 ;
78CREF ;check for deleted refills
79 S BDA=DA,XX=0,BRB="" F S XX=$O(^PS(52.11,BDA,2,XX)) Q:'XX S DA=XX D
80 .S BRX0=$G(^PS(52.11,BDA,2,DA,0)),BRX1=$P(BRX0,"^"),BRXFL=$P(BRX0,"^",2),BRXFLN=$P(BRX0,"^",3)
81 .I BRXFLN,BRXFL="F",$G(^PSRX(BRX1,1,BRXFLN,0))']"" D
82 ..S DA(1)=BDA,DIK="^PS(52.11,"_DA(1)_",2," D ^DIK K DIK,DA(1)
83 ..S BRB=BRB_$S(BRB="":"",1:"; ")_BRX1_","_BRXFLN
84 S DA=BDA I BRB]"",$P($G(^PS(52.11,BDA,2,0)),"^",4)=0 D
85 .W !!,$C(7),"Refill(s) "_BRB_" does not exist.",!,"It can't be displayed and is now deleted."
86 .S DIK="^PS(52.11," D ^DIK S PSODRF=1
87 K BDA,BRB,BRX0,BRX1,BRXFL,BRXFLN
88 Q
89 ;
90REL S BNGRXP=RXP N NAM,NAME,RXO,SSN
91 S NAM=$P($G(^DPT(BINGNAM,0)),"^"),ADA="",BNGRXP=RXP
92 F XX=0:0 S XX=$O(^PS(52.11,"B",BINGNAM,XX)) Q:'XX D
93 .F BRX=0:0 S BRX=$O(^PS(52.11,XX,2,"B",BRX)) Q:'BRX D
94 ..I BRX=BNGRXP S (DA,ODA)=XX
95 I '$D(DA) W !!,"The Rx for ",NAM," isn't in the Bingo Board",!,"file and must be entered manually.",$C(7) G END
96 I $P($G(^PS(52.11,DA,0)),"^",7)]"" W !!,NAM," is already in the display queue.",$C(7) G END
97 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
98 G:$P($G(^PS(52.11,DA,0)),"^",9) REL1
99 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
100 I $D(BINGRO),$D(BINGDIV) S BDIV=BINGDIV G REL1
101 I $D(BINGRPR),$D(BNGPDV) S BDIV=BNGPDV G REL1
102 I $D(BINGRPR),$D(BNGRDV) S BDIV=BNGRDV G REL1
103REL1 N TM,TM1 D NOW^%DTC S TM=$E(%,1,12),TM1=$P(TM,".",2)
104 S NM=$P(^DPT($P(^PS(52.11,DA,0),"^"),0),"^"),DR="6////"_$E(TM1_"0000",1,4)_";8////"_NM_"",DIE="^PS(52.11,"
105 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
106 D ^DIE L -^PS(52.11,DA) I $G(DUOUT)!($G(DTOUT))!(X="") D WARN G END
107 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
108 W !!,NAM," added to the "_$P($G(^PS(59.3,$P(RX0,"^",3),0)),"^")_" display."
109 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."
110 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
111 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
112 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
113 S DA=ODA D STATS1^PSOBRPRT,WTIME
114END K ADA,BDA,BDIV,BNGRXP,BNGSUS,BNAME,BRX,CNT1,CT,DA,DD,DIC,DIE,DIK,DIR,DO,DR,DTOUT,DUOUT,GRP,GRTP,JOES
115 K NAM,NDA,NFLAG,NME,ODA,PSZ,RXO,SSN,TDFN,TFLAG,TIC,TICK,TIEN,TM,TM1,TSSN,X,Y,XX
116 Q
Note: See TracBrowser for help on using the repository browser.