source: WorldVistAEHR/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDFT1.m@ 789

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

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PSDFT1 ;B'ham ISC/JPW,LTL - File NDES Info ; 26 June 95
2 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
3DFT ;process the incoming message
4 N PSD,PSD1
5 F PSD=1:1 X HLNEXT Q:HLQUIT'>0 S PSD(PSD)=HLNODE,PSD1=0 F S PSD1=$O(HLNODE(PSD1)) Q:'PSD1 S PSD1(PSD1)=HLNODE(PSD1)
6LOOP ;loop thru data from DFT message
7 N NAOU,PSDPID,PSDPV1,PSDFT1,PSDZPM,PSDM,PSDTYP,NUR1,NUR2,PAT
8 S PSDPID=$G(PSD(3)),PSDPV1=$G(PSD(4))
9 S PSDFT1=$G(PSD(5)),PSDZPM=$G(PSD(6))
10 I '$D(^PSDRUG(+$P(PSDFT1,HL("FS"),8),0)) G ACK
11 I $D(^PSDRUG(+$P(PSDFT1,HL("FS"),8),0)),$P($G(^PSDRUG(+$P(PSDFT1,HL("FS"),8),2)),U,3)'["N" G ACK
12 S (NAOU,NAOU(2))=$P($P(PSDPV1,HL("FS"),4),$E(HL("ECH")))
13 S:NAOU]"" NAOU=$O(^DIC(42,"B",NAOU,0))
14 I 'NAOU S DFN=+$P(PSDPID,HL("FS"),4) D INP^VADPT S NAOU=+VAIN(4) D KVA^VADPT
15 S NAOU(1)=0 F S NAOU(1)=$O(^PSD(58.8,"AB",+NAOU,NAOU(1))) Q:$P($G(^PSD(58.8,+NAOU(1),0)),U,2)="N"!('NAOU(1))
16 S:'NAOU(1) PSDM(1)="* "_$S(NAOU(2)']"":"No Ward Location",'NAOU!('$D(^DIC(42,+NAOU))):NAOU(2)_" is not a valid Ward Location.",1:$P($G(^DIC(42,+NAOU,0)),U)_" is not linked to an NAOU.")
17 S PSDTYP=$E($P(PSDFT1,HL("FS"),7)),PSDTYP(1)=$S(PSDTYP="D"!(PSDTYP="CHARGE"):17,PSDTYP="W":18,PSDTYP="R"!(PSDTYP="CREDIT"):3,PSDTYP="V":17,1:"")
18 S:'PSDTYP(1) PSDM(2)="* "_$S(PSDTYP']"":"No type",1:PSDTYP_" is not a valid action,")_" must be (D)ispensed, (W)asted, or (R)eturned."
19 S (X,NUR1)=$P($P(PSDFT1,HL("FS"),21),$E(HL("ECH")),2)
20NUR S DIC="^VA(200,",DIC(0)="M" D ^DIC S NUR1(1)=+Y
21 I Y<1 S X=$P(X,",") D ^DIC S NUR1(1)=+Y
22 K DIC
23 S:'$D(^VA(200,NUR1(1),0)) PSDM(3)="* No VA Nurse match for "_$S(NUR1]"":NUR1,1:"Unknown Nurse")
24 S (X,NUR2)=$P(PSDZPM,HL("FS"),16)
25 S DIC="^VA(200,",DIC(0)="M" D ^DIC S NUR2(1)=+Y
26 I Y<1 S X=$P(X,",") D ^DIC S NUR2(1)=+Y
27 K DIC
28 S:PSDTYP="W"&('$D(^VA(200,NUR2(1),0))) PSDM(3.5)="* No Va Witness match for "_$S(NUR2]"":NUR2,1:"Unknown Witness")
29 S PAT=+$P(PSDPID,HL("FS"),4)
30 S:'PAT!('$D(^DPT(PAT))) PSDM(4)="* "_$S(PAT:PAT_" is NOT a valid PATIENT ID",1:"NO PATIENT ID")_" for "_$S($P(PSDPID,HL("FS"),6)]"":$P(PSDPID,HL("FS"),6),1:"UNKNOWN PATIENT")
31 S:'$D(PSDM(4))&($P($G(^DPT(PAT,0)),U)'[$P($P(PSDPID,HL("FS"),6),U)) PSDM(4)="VA patient name: "_$P($G(^(0)),U)_" System name: "_$P(PSDPID,HL("FS"),6)
32 S PSDR=$P(PSDFT1,HL("FS"),8)
33 D:'+PSDR!('$D(^PSD(58.8,+NAOU(1),1,+PSDR)))&($G(PSDM(1))']"")
34 .S PSDM(5)="* Drug #"_$S($P(PSDR,$E(HL("ECH")))]"":$P(PSDR,$E(HL("ECH")))_" is not stocked,",1:"No drug ID")_" drug: "_$S($P(PSDR,$E(HL("ECH")),2)]"":$P(PSDR,$E(HL("ECH")),2),1:"UNKNOWN DRUG")
35 S QTY=+$P(PSDFT1,HL("FS"),11),NUR2="" S:PSDTYP(1)="R" QTY=-QTY
36 S PSDT=$$FMDATE^HLFNC($G(HL("DTM")))
37 S Y=PSDT X ^DD("DD") S %DT="RX",(X,PSDT(1))=$P(Y,":",1,2) D ^%DT
38 S:Y=-1 PSDM(6)="* "_PSDT(1)_" is not a valid date, exact date/time are required."
39 D:$O(PSDM(0))
40 .N PSD D KILL^XM
41 .S XMSUB="Narcotic Dispensing Equipment System Error"
42 .S XMDUZ="Interface Monitor"
43 .D XMZ^XMA2 I XMZ<1 D KILL^XM Q
44 .S XMY(DUZ)="",PSD=0
45 .F S PSD=$O(^XUSEC("PSD ERROR",PSD)) Q:'PSD S XMY(PSD)=""
46 .S PSDM(.1)="The following transmission did NOT update the Controlled Substances package:",PSDM(.2)=""
47 .S:NAOU(1) PSDM(.3)="NAOU: "_$P($G(^PSD(58.8,+NAOU(1),0)),U)
48 .S:PSDTYP(1) PSDM(.4)="Transaction type: "_$S("DV"[PSDTYP:"Dispensed",PSDTYP="R":"Returned",1:"Wasted")
49 .S:'$D(PSDM(3)) PSDM(.5)="Nurse: "_$P($G(^VA(200,+NUR1(1),0)),U)
50 .S:PSDTYP="W"&('$D(PSDM(3.5))) PSDM(.51)="Witness: "_$P($G(^VA(200,+NUR2,0)),U)
51 .S:'$D(PSDM(4)) PSDM(.6)="Patient: "_$P($G(^DPT(PAT,0)),U)
52 .S:'$D(PSDM(5)) PSDM(.7)="Drug: "_$P($G(^PSDRUG(+PSDR,0)),U)_" QTY: "_QTY
53 .S:'$D(PSDM(6)) PSDM(.8)="Date/Time: "_PSDT(1)
54 .S PSDM(.9)="",PSDM(.91)="No update occurred to Controlled Substances",PSDM(.92)="because of the following discrepancy:",PSDM(.93)=""
55 .S XMTEXT="PSDM(" D ^XMD,KILL^XM
56 S QTY=-QTY
57 ;D:QTY&('$D(PSDM)) UPDATE
58ACK ;Send ack back
59 S HLEID=HL("EID"),HLEIDS=HL("EIDS"),HLARYTYP="LM",HLFORMAT=1
60 S (HLRESLTA,HLMTIENA,HLP)=""
61 S HLA("HLA",1)="MSA"_HL("FS")_"AA"_HL("FS")_HL("MID")_HL("FS")_"MESSAGE PROCESSED"
62 D GENACK^HLMA1(HLEID,HLMTIENS,HLEIDS,HLARYTYP,HLFORMAT,.HLRESLTA,HLMTIENA,.HLP)
63END K %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,OK,OQTY,ORD
64 K PAT,PATL,PSD,PSDER,PSDPN,PSDR,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
65OP Q
66UPDATE ;update 58.8 and 58.81
67 ;updating drug balance in 58.8
68 F L +^PSD(58.8,+NAOU(1),1,+PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
69 D NOW^%DTC S PSDTN=+%
70 S BAL=$P(^PSD(58.8,+NAOU(1),1,+PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+QTY
71 L -^PSD(58.8,+NAOU(1),1,+PSDR,0)
72ADD ;find entry number in 58.81
73 F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
74FIND S PSDREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDREC)) S $P(^PSD(58.81,0),"^",3)=PSDREC G FIND
75 K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO
76 L -^PSD(58.81,0)
77EDIT ;edit new transaction in 58.81
78 S ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP(1)_"^"_+NAOU(1)_"^"_PSDT_"^"_+PSDR_"^"_QTY_"^^^^"_BAL_"^^^^^^^^"_+NAOU(1)_"^^"
79 ;get specialty for patient
80 S DFN=PAT,VAROOT="PSD" D INP^VADPT
81 S ^PSD(58.81,PSDREC,9)=PAT_"^"_+NUR1_"^^"_$S(PSDTYP(1)=18:-QTY,1:"")_"^^"_NUR2_"^^^^^^^"_$P($G(^DIC(45.7,+PSD(3),0)),U,2)
82 S ^PSD(58.81,PSDREC,"CS")=1
83 K DA,DIK,PSD,VAERR S DA=PSDREC,DIK="^PSD(58.81," D IX^DIK K DA,DIK
84 W "."
85 Q
86ERR ;err log update
87 F L +^PSD(58.89,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
88FIND9 S PSDER=$P(^PSD(58.89,0),"^",3)+1 I $D(^PSD(58.89,PSDER)) S $P(^PSD(58.89,0),"^",3)=PSDER G FIND9
89 K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.89,(X,DINUM)=PSDER D ^DIC K DIC,DLAYGO
90 L -^PSD(58.89,0)
91EDIT9 ;edit error log
92 K DA,DIE,DR S DA=PSDER,DIE=58.89,DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU D ^DIE K DA,DIE,DR
93 D ^PSDFILM
94 Q
Note: See TracBrowser for help on using the repository browser.