PSDFT ;B'ham ISC/JPW,LTL - File NDES Info ; 26 June 95
;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
LOOP ;loop thru data from DFT message
N NAOU,PSD,PSDPID,PSDPV1,PSDFT1,PSDZPM,PSDM,PSDTYP,NUR1,NUR2,PAT
S PSDPID=$G(^HL(772,HLDA,"IN",3,0)),PSDPV1=$G(^HL(772,HLDA,"IN",4,0))
S PSDFT1=$G(^HL(772,HLDA,"IN",5,0)),PSDZPM=$G(^HL(772,HLDA,"IN",6,0))
S NAOU=$P($P(PSDPV1,HLFS,4),$E(HLECH))
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))
S:'NAOU(1) PSDM(1)="* "_$S(NAOU']"":"No Ward Location",'$D(^DIC(42,+NAOU)):NAOU_" is not a valid Ward Location (IEN).",1:$P($G(^DIC(42,+NAOU,0)),U)_" is not linked to an NAOU.")
S PSDTYP=$E($P(PSDFT1,HLFS,7)),PSDTYP(1)=$S(PSDTYP="D":17,PSDTYP="W":18,PSDTYP="R":3,PSDTYP="V":17,1:"")
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."
S NUR1=$P(PSDFT1,HLFS,21),NUR1(1)=+NUR1
S:'$D(^VA(200,NUR1(1),0)) PSDM(3)="* "_$S(NUR1(1):NUR1(1)_" is invalid ID",1:"No Nurse ID")_" for "_$S($P(NUR1,$E(HLECH),2)]"":$P(NUR1,$E(HLECH),2),1:"Unknown Nurse")
S NUR2=$P(PSDZPM,HLFS,15),NUR2(1)=+NUR2
S:PSDTYP="W"&('$D(^VA(200,NUR2(1),0))) PSDM(3.5)="* "_$S(NUR2(1):NUR2(1)_" is invalid witness ID",1:"No witness ID")_" for "_$S($P(NUR2,$E(HLECH),2)]"":$P(NUR2,$E(HLECH),2),1:"Unknown Witness")
S PAT=+$P(PSDPID,HLFS,4)
S:'$D(^DPT(PAT)) PSDM(4)="* "_$S(PAT:PAT_" is an invalid ID",1:"NO ID")_" for "_$S($P(PSDPID,HLFS,6)]"":$$FMNAME^HLFNC($P(PSDPID,HLFS,6)),1:"UNKNOWN PATIENT")
S PSDR=$P(PSDFT1,HLFS,8)
S:'$D(^PSD(58.8,+NAOU(1),1,+PSDR)) PSDM(5)="* Drug #"_$S($P(PSDR,$E(HLECH))]"":$P(PSDR,$E(HLECH))_" is not stocked,",1:"No drug ID")_" drug: "_$S($P(PSDR,$E(HLECH),2)]"":$P(PSDR,$E(HLECH),2),1:"UNKNOWN DRUG")
S QTY=+$P(PSDFT1,HLFS,11),NUR2="" S:PSDTYP(1)="R" QTY=-QTY
S PSDT=$$FMDATE^HLFNC($P($G(^HL(772,HLDA,"IN",1,0)),HLFS,7))
S Y=PSDT X ^DD("DD") S %DT="RX",(X,PSDT(1))=Y D ^%DT
S:Y<1 PSDM(6)="* "_PSDT(1)_" is an not a valid date, exact date/time are required."
D:$O(PSDM(0))
.N PSD D KILL^XM
.S XMSUB="Narcotic Dispensing Equipment System Error"
.S XMDUZ="Interface Monitor"
.D XMZ^XMA2 I XMZ<1 D KILL^XM Q
.S XMY(DUZ)="",PSD=0
.F S PSD=$O(^XUSEC("PSD ERROR",PSD)) Q:'PSD S XMY(PSD)=""
.S PSDM(.1)="The following transmission did NOT update the Controlled Substances package:",PSDM(.2)=""
.S:NAOU(1) PSDM(.3)="NAOU: "_$P($G(^PSD(58.8,+NAOU(1),0)),U)
.S:PSDTYP(1) PSDM(.4)="Transaction type: "_$S("DV"[PSDTYP:"Dispensed",PSDTYP="R":"Returned",1:"Wasted")
.S:'$D(PSDM(3)) PSDM(.5)="Nurse: "_$P($G(^VA(200,+NUR1,0)),U)
.S:PSDTYP="W"&('$D(PSDM(3.5))) PSDM(.51)="Witness: "_$P($G(^VA(200,+NUR2,0)),U)
.S:'$D(PSDM(4)) PSDM(.6)="Patient: "_$P($G(^DPT(PAT,0)),U)
.S:'$D(PSDM(5)) PSDM(.7)="Drug: "_$P($G(^PSDRUG(+PSDR,0)),U)_" QTY: "_QTY
.S:'$D(PSDM(6)) PSDM(.8)="Date/Time: "_PSDT(1)
.S PSDM(.9)="",PSDM(.91)="No update occurred to Controlled Substances",PSDM(.92)="because of the following discrepancy:",PSDM(.93)=""
.S XMTEXT="PSDM(" D ^XMD,KILL^XM
S QTY=-QTY
D:QTY&('$D(PSDM)) UPDATE
;Send ack back
S HLSDATA(2)="MSA"_HLFS_"AA"_HLFS_$P(HLSDATA(1),HLFS,10)_HLFS_"MESSAGE PROCESSED",HLEVN=1 D EN1^HLTRANS
END K %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,OK,OQTY,ORD
K PAT,PATL,PSD,PSDER,PSDPN,PSDR,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
OP Q
UPDATE ;update 58.8 and 58.81
;updating drug balance in 58.8
F L +^PSD(58.8,+NAOU(1),1,+PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSDTN=+%
S BAL=$P(^PSD(58.8,+NAOU(1),1,+PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+QTY
L -^PSD(58.8,+NAOU(1),1,+PSDR,0)
ADD ;find entry number in 58.81
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND 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
K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO
L -^PSD(58.81,0)
EDIT ;edit new transaction in 58.81
S ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP(1)_"^"_+NAOU(1)_"^"_PSDT_"^"_+PSDR_"^"_QTY_"^^^^"_BAL_"^^^^^^^^"_+NAOU(1)_"^^"
;get specialty for patient
S DFN=PAT,VAROOT="PSD" D INP^VADPT
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)
S ^PSD(58.81,PSDREC,"CS")=1
K DA,DIK,PSD,VAERR S DA=PSDREC,DIK="^PSD(58.81," D IX^DIK K DA,DIK
W "."
Q
ERR ;err log update
F L +^PSD(58.89,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND9 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
K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.89,(X,DINUM)=PSDER D ^DIC K DIC,DLAYGO
L -^PSD(58.89,0)
EDIT9 ;edit error log
K DA,DIE,DR S DA=PSDER,DIE=58.89,DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU D ^DIE K DA,DIE,DR
D ^PSDFILM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDFT 4907 printed Apr 09, 2024@20:51:52 Page 2
PSDFT ;B'ham ISC/JPW,LTL - File NDES Info ; 26 June 95
+1 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
LOOP ;loop thru data from DFT message
+1 NEW NAOU,PSD,PSDPID,PSDPV1,PSDFT1,PSDZPM,PSDM,PSDTYP,NUR1,NUR2,PAT
+2 SET PSDPID=$GET(^HL(772,HLDA,"IN",3,0))
SET PSDPV1=$GET(^HL(772,HLDA,"IN",4,0))
+3 SET PSDFT1=$GET(^HL(772,HLDA,"IN",5,0))
SET PSDZPM=$GET(^HL(772,HLDA,"IN",6,0))
+4 SET NAOU=$PIECE($PIECE(PSDPV1,HLFS,4),$EXTRACT(HLECH))
+5 SET NAOU(1)=0
FOR
SET NAOU(1)=$ORDER(^PSD(58.8,"AB",+NAOU,NAOU(1)))
if $PIECE($GET(^PSD(58.8,+NAOU(1),0)),U,2)="N"!('NAOU(1))
QUIT
+6 if 'NAOU(1)
SET PSDM(1)="* "_$SELECT(NAOU']"":"No Ward Location",'$DATA(^DIC(42,+NAOU)):NAOU_" is not a valid Ward Location (IEN).",1:$PIECE($GET(^DIC(42,+NAOU,0)),U)_" is not linked to an NAOU.")
+7 SET PSDTYP=$EXTRACT($PIECE(PSDFT1,HLFS,7))
SET PSDTYP(1)=$SELECT(PSDTYP="D":17,PSDTYP="W":18,PSDTYP="R":3,PSDTYP="V":17,1:"")
+8 if 'PSDTYP(1)
SET PSDM(2)="* "_$SELECT(PSDTYP']"":"No type",1:PSDTYP_" is not a valid action,")_" must be (D)ispensed, (W)asted, or (R)eturned."
+9 SET NUR1=$PIECE(PSDFT1,HLFS,21)
SET NUR1(1)=+NUR1
+10 if '$DATA(^VA(200,NUR1(1),0))
SET PSDM(3)="* "_$SELECT(NUR1(1):NUR1(1)_" is invalid ID",1:"No Nurse ID")_" for "_$SELECT($PIECE(NUR1,$EXTRACT(HLECH),2)]"":$PIECE(NUR1,$EXTRACT(HLECH),2),1:"Unknown Nurse")
+11 SET NUR2=$PIECE(PSDZPM,HLFS,15)
SET NUR2(1)=+NUR2
+12 if PSDTYP="W"&('$DATA(^VA(200,NUR2(1),0)))
SET PSDM(3.5)="* "_$SELECT(NUR2(1):NUR2(1)_" is invalid witness ID",1:"No witness ID")_" for "_$SELECT($PIECE(NUR2,$EXTRACT(HLECH),2)]"":$PIECE(NUR2,$EXTRACT(HLECH),2),1:"Unknown Witness")
+13 SET PAT=+$PIECE(PSDPID,HLFS,4)
+14 if '$DATA(^DPT(PAT))
SET PSDM(4)="* "_$SELECT(PAT:PAT_" is an invalid ID",1:"NO ID")_" for "_$SELECT($PIECE(PSDPID,HLFS,6)]"":$$FMNAME^HLFNC($PIECE(PSDPID,HLFS,6)),1:"UNKNOWN PATIENT")
+15 SET PSDR=$PIECE(PSDFT1,HLFS,8)
+16 if '$DATA(^PSD(58.8,+NAOU(1),1,+PSDR))
SET PSDM(5)="* Drug #"_$SELECT($PIECE(PSDR,$EXTRACT(HLECH))]"":$PIECE(PSDR,$EXTRACT(HLECH))_" is not stocked,",1:"No drug ID")_" drug: "_$SELECT($PIECE(PSDR,$EXTRACT(HLECH),2)]"":$PIECE(PSDR,$EXTRACT(HLECH),2),1:"UNKNOWN DRUG")
+17 SET QTY=+$PIECE(PSDFT1,HLFS,11)
SET NUR2=""
if PSDTYP(1)="R"
SET QTY=-QTY
+18 SET PSDT=$$FMDATE^HLFNC($PIECE($GET(^HL(772,HLDA,"IN",1,0)),HLFS,7))
+19 SET Y=PSDT
XECUTE ^DD("DD")
SET %DT="RX"
SET (X,PSDT(1))=Y
DO ^%DT
+20 if Y<1
SET PSDM(6)="* "_PSDT(1)_" is an not a valid date, exact date/time are required."
+21 if $ORDER(PSDM(0))
Begin DoDot:1
+22 NEW PSD
DO KILL^XM
+23 SET XMSUB="Narcotic Dispensing Equipment System Error"
+24 SET XMDUZ="Interface Monitor"
+25 DO XMZ^XMA2
IF XMZ<1
DO KILL^XM
QUIT
+26 SET XMY(DUZ)=""
SET PSD=0
+27 FOR
SET PSD=$ORDER(^XUSEC("PSD ERROR",PSD))
if 'PSD
QUIT
SET XMY(PSD)=""
+28 SET PSDM(.1)="The following transmission did NOT update the Controlled Substances package:"
SET PSDM(.2)=""
+29 if NAOU(1)
SET PSDM(.3)="NAOU: "_$PIECE($GET(^PSD(58.8,+NAOU(1),0)),U)
+30 if PSDTYP(1)
SET PSDM(.4)="Transaction type: "_$SELECT("DV"[PSDTYP:"Dispensed",PSDTYP="R":"Returned",1:"Wasted")
+31 if '$DATA(PSDM(3))
SET PSDM(.5)="Nurse: "_$PIECE($GET(^VA(200,+NUR1,0)),U)
+32 if PSDTYP="W"&('$DATA(PSDM(3.5)))
SET PSDM(.51)="Witness: "_$PIECE($GET(^VA(200,+NUR2,0)),U)
+33 if '$DATA(PSDM(4))
SET PSDM(.6)="Patient: "_$PIECE($GET(^DPT(PAT,0)),U)
+34 if '$DATA(PSDM(5))
SET PSDM(.7)="Drug: "_$PIECE($GET(^PSDRUG(+PSDR,0)),U)_" QTY: "_QTY
+35 if '$DATA(PSDM(6))
SET PSDM(.8)="Date/Time: "_PSDT(1)
+36 SET PSDM(.9)=""
SET PSDM(.91)="No update occurred to Controlled Substances"
SET PSDM(.92)="because of the following discrepancy:"
SET PSDM(.93)=""
+37 SET XMTEXT="PSDM("
DO ^XMD
DO KILL^XM
End DoDot:1
+38 SET QTY=-QTY
+39 if QTY&('$DATA(PSDM))
DO UPDATE
+40 ;Send ack back
+41 SET HLSDATA(2)="MSA"_HLFS_"AA"_HLFS_$PIECE(HLSDATA(1),HLFS,10)_HLFS_"MESSAGE PROCESSED"
SET HLEVN=1
DO EN1^HLTRANS
END KILL %,%DT,%H,%I,BAL,CQTY,DA,DIC,DIE,DIK,DINUM,DLAYGO,DR,JJ,LQTY,NAOUN,NODE,OK,OQTY,ORD
+1 KILL PAT,PATL,PSD,PSDER,PSDPN,PSDR,PSDREC,PSDRN,PSDT,PSDTN,QTY,WQTY,X,Y
OP QUIT
UPDATE ;update 58.8 and 58.81
+1 ;updating drug balance in 58.8
+2 FOR
LOCK +^PSD(58.8,+NAOU(1),1,+PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 DO NOW^%DTC
SET PSDTN=+%
+4 SET BAL=$PIECE(^PSD(58.8,+NAOU(1),1,+PSDR,0),"^",4)
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+QTY
+5 LOCK -^PSD(58.8,+NAOU(1),1,+PSDR,0)
ADD ;find entry number in 58.81
+1 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSDREC=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSDREC))
SET $PIECE(^PSD(58.81,0),"^",3)=PSDREC
GOTO FIND
+1 KILL DIC,DLAYGO
SET DIC(0)="L"
SET (DIC,DLAYGO)=58.81
SET (X,DINUM)=PSDREC
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.81,0)
EDIT ;edit new transaction in 58.81
+1 SET ^PSD(58.81,PSDREC,0)=PSDREC_"^"_PSDTYP(1)_"^"_+NAOU(1)_"^"_PSDT_"^"_+PSDR_"^"_QTY_"^^^^"_BAL_"^^^^^^^^"_+NAOU(1)_"^^"
+2 ;get specialty for patient
+3 SET DFN=PAT
SET VAROOT="PSD"
DO INP^VADPT
+4 SET ^PSD(58.81,PSDREC,9)=PAT_"^"_+NUR1_"^^"_$SELECT(PSDTYP(1)=18:-QTY,1:"")_"^^"_NUR2_"^^^^^^^"_$PIECE($GET(^DIC(45.7,+PSD(3),0)),U,2)
+5 SET ^PSD(58.81,PSDREC,"CS")=1
+6 KILL DA,DIK,PSD,VAERR
SET DA=PSDREC
SET DIK="^PSD(58.81,"
DO IX^DIK
KILL DA,DIK
+7 WRITE "."
+8 QUIT
ERR ;err log update
+1 FOR
LOCK +^PSD(58.89,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND9 SET PSDER=$PIECE(^PSD(58.89,0),"^",3)+1
IF $DATA(^PSD(58.89,PSDER))
SET $PIECE(^PSD(58.89,0),"^",3)=PSDER
GOTO FIND9
+1 KILL DIC,DLAYGO
SET DIC(0)="L"
SET (DIC,DLAYGO)=58.89
SET (X,DINUM)=PSDER
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.89,0)
EDIT9 ;edit error log
+1 KILL DA,DIE,DR
SET DA=PSDER
SET DIE=58.89
SET DR="1////"_PSDREC_";2////"_PSDT_";6////"_NAOU
DO ^DIE
KILL DA,DIE,DR
+2 DO ^PSDFILM
+3 QUIT
