PSATI ;BIR/LTL-Single Drug Match ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**8,18,23,21**; 10/24/97
;This routine enters/edits links with the ITEM MASTER file.
;
;References to $$DESCR^PRCPUX1 are covered by IA #259
;References to $$VENNAME^PRCPUX1 are covered by IA #259
;References to ^PRC( are covered by IA #214
;References to ^PSDRUG( are covered by IA #2095
;
N PSAIT,DTOUT,DUOUT,DIE,D0,D1,DA,DIC,DIR,DLAYGO,DR,DIRUT
START D DT^DICRW
;For call by ^PSAENT & ^PSAUNL
I $G(PSAIT) S DIC(0)="Q",X=PSAIT W !!,$P($G(^PSDRUG(+PSAIT,0)),U),!!
;LOOK UP DRUG
LOOK S:'$D(DIC(0)) DIC(0)="AEMQ" S DIC=50,DIC("S")="I $S('$D(^(""I"")):1,+^(""I"")>DT:1,1:0)" D ^DIC K DIC G:$D(DTOUT)!($D(DUOUT))!(Y<0) QUIT S (PSADRUG,PSAIT)=$P(Y,U)
DIS I $O(^PSDRUG(+PSADRUG,441,0)) W !,"This drug is currently linked to the following item(s):",!! S PSAIM=0 F S PSAIM=$O(^PSDRUG(PSADRUG,441,PSAIM)) Q:PSAIM="B" S PSAI=$P(^PSDRUG(PSADRUG,441,PSAIM,0),U) D:$$DESCR^PRCPUX1(0,PSAI)]""
.W !,PSAI_" "_$$DESCR^PRCPUX1(0,PSAI)_" ",$$VENNAME^PRCPUX1($P($G(^PRC(441,+PSAI,0)),U,4)_"PRC(440"),!
QUES1 I $D(PSAI) S DIR(0)="Y",DIR("A")="Would you like to alter the link(s)",DIR("B")="No" D ^DIR K DIR G:Y<1&('$D(PSALOC)) AGAIN G:Y<1 QUIT
W !!,"Current potential ITEM MASTER file links based on NDC or FSN are:",!!
;Attempt match by NDC between #50/#441
NDC I $P($G(^PSDRUG(PSADRUG,2)),U,4)]"" S PSANDC=$P(^(2),U,4),PSAI=$$ITEM^PSAUTL(PSANDC) W "DRUG file NDC: "_PSANDC
I $D(PSAI),$D(PSANDC),PSAI W ?40,"ITEM NUMBER: "_PSAI,!!,"DESC: "_$$DESCR^PRCPUX1(0,PSAI),! W:$G(^PRC(441,+PSAI,3)) !?60,"* Inactive item" D:$O(^PRC(441,"F",PSANDC,PSAI))
MORE .S PSAZ=1,PSAI(PSAZ)=PSAI F S PSAI(PSAZ)=$O(^PRC(441,"F",PSANDC,PSAI(PSAZ))) Q:PSAI(PSAZ)="" W !?40,"ITEM NUMBER: "_PSAI(PSAZ),!!,"DESC: ",$$DESCR^PRCPUX1(0,PSAI(PSAZ)) W:$G(^PRC(441,+PSAI(PSAZ),3)) !?60,"* Inactive item"
;Attempt match between FSN (#50) and NSN (#441)
FSN I '$G(PSAI),$P(^PSDRUG(PSADRUG,0),U,6)]"" S PSAFSN=$P(^(0),U,6) D:$D(^PRC(441,"BB",PSAFSN))
.S PSAI=$O(^PRC(441,"BB",PSAFSN,"")) W " NO NDC MATCH IN ITEM MASTER file.",!!,"DRUG file FSN: "_PSAFSN,?40,"ITEM NUMBER: "_PSAI,!!,"DESC: ",$$DESCR^PRCPUX1(0,PSAI),!
FAIL S:'$D(PSAI) PSAI="" W:PSAI']"" !!,"No NDC or FSN match in the ITEM MASTER file.",!
;S:'$D(^PSDRUG(+PSADRUG,441,0)) ^(0)="^50.0441P^^" ;Removed by SQA recommendation (PSA*3*18)
CON S DIE="^PSDRUG(",DA=PSADRUG,DR="441//^S X=$G(PSAI)" D ^DIE K DIE I $D(Y)!($D(DTOUT)) S DIRUT=1 G QUIT
I '$D(^PSDRUG(PSADRUG,"ND")) W !!,"No NDF link, can't help.",! G AGAIN
I $P(^PSDRUG(PSADRUG,"ND"),U)']"" W !!,"No NDF link, can't help.",! K DUOUT G AGAIN
;Check for package size or type = OTHER
I $P($G(^PSDRUG(+PSADRUG,"ND")),U,4)=2058 W !!,"No matching PACKAGE SIZE in the National Drug File." G AGAIN
I $P($G(^PSDRUG(+PSADRUG,"ND")),U,5)=623 W !!,"No matching PACKAGE TYPE in the National Drug file." G AGAIN
NDF ;Offer NDF path
W !!,"This drug is linked to the NATIONAL DRUG file.",!!,"There may be an NDC there that will link to the ITEM MASTER file.",!
S DIR(0)="Y",DIR("A")="Would you like to check",DIR("B")="No" D ^DIR K DIR G:$D(DIRUT)!(Y<1) AGAIN
;
;DAVE B (PSA*3*18) Old NDF globals no longer used.
S PSAVP=$P($G(^PSDRUG(PSADRUG,"ND")),"^",3) I $G(PSAVP)="" W !,"Sorry, there is no entry in the PSNDF VA PRODUCT NAME, cannot find match.",! G AGAIN
;Call PSNAPIS
S X=$$CIRN2^PSNAPIS("",PSAVP,.PSANDF)
S PSX="" F S PSX=$O(PSANDF(PSX)) Q:PSX="" K PSA D Q:Y<1 D BINGO
.I PSX'["-" S PSAOLD=$G(PSANDC),PSANDC=PSX D PSANDC1^PSAHELP S PSA=PSANDCX K PSANDCX I $G(PSAOLD)'="" S PSANDC=PSAOLD K PSAOLD
.I $G(PSA)="" S PSA=PSX
.W !,"Going to check NDC #"_PSA,! S DIR(0)="Y",DIR("A")="OK",DIR("B")="No" D ^DIR K DIR Q:$D(DIRUT)!(Y<1)
AGAIN K PSA,PSAD,PSADO,PSADRUG,PSAF,PSAFSN,PSANDC,PSANDF,PSAI,PSAIM,PSAIQ,PSAIQT,PSAIAC,PSAILC,PSAINV,PSAINVN,PSAP,PSAPB,PSAS,PSAT,PSATB,PSAU,PSAV,PSAZ,X,Y
Q:$D(PSAS)!($D(PSALOC)) W ! S DIR(0)="Y",DIR("A")="Another drug",DIR("B")="Yes" D ^DIR K DIR I Y>0 K PSAIT,PSAI G START
QUIT N:'$G(PSAIT(1)) PSAIT,Y K PSA,PSAI,PSAD,PSADO,PSADRUG,PSAF,PSAFSN,PSANDC,PSANDF,PSAI,PSAIM,PSAIQ,PSAIQT,PSAIAC,PSAILC,PSAINV,PSAINVN,PSAP,PSAPB,PSAS,PSAT,PSATB,PSAU,PSAV,PSAZ,X,Y Q
BINGO S PSAI=$O(^PRC(441,"F",PSA,""))
Q:$O(^PSDRUG("AB",+PSAI,0))
W !!,"DRUG file: "_$P(^PSDRUG(PSADRUG,0),U),!!,"Item #: "_PSAI," Desc: ",$$DESCR^PRCPUX1(0,PSAI),! D
.S DIR(0)="Y",DIR("A")="OK to link",DIR("B")="Yes",DIR("?")="If yes, I'll perform the link" D ^DIR K DIR K:(Y=0) Y Q:($G(Y)<1)
.S DIE=50,DA=PSADRUG,DR="441///^S X=""`""_PSAI" D ^DIE W " linked."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSATI 4623 printed Sep 23, 2025@19:26:41 Page 2
PSATI ;BIR/LTL-Single Drug Match ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**8,18,23,21**; 10/24/97
+2 ;This routine enters/edits links with the ITEM MASTER file.
+3 ;
+4 ;References to $$DESCR^PRCPUX1 are covered by IA #259
+5 ;References to $$VENNAME^PRCPUX1 are covered by IA #259
+6 ;References to ^PRC( are covered by IA #214
+7 ;References to ^PSDRUG( are covered by IA #2095
+8 ;
+9 NEW PSAIT,DTOUT,DUOUT,DIE,D0,D1,DA,DIC,DIR,DLAYGO,DR,DIRUT
START DO DT^DICRW
+1 ;For call by ^PSAENT & ^PSAUNL
+2 IF $GET(PSAIT)
SET DIC(0)="Q"
SET X=PSAIT
WRITE !!,$PIECE($GET(^PSDRUG(+PSAIT,0)),U),!!
+3 ;LOOK UP DRUG
LOOK if '$DATA(DIC(0))
SET DIC(0)="AEMQ"
SET DIC=50
SET DIC("S")="I $S('$D(^(""I"")):1,+^(""I"")>DT:1,1:0)"
DO ^DIC
KILL DIC
if $DATA(DTOUT)!($DATA(DUOUT))!(Y<0)
GOTO QUIT
SET (PSADRUG,PSAIT)=$PIECE(Y,U)
DIS IF $ORDER(^PSDRUG(+PSADRUG,441,0))
WRITE !,"This drug is currently linked to the following item(s):",!!
SET PSAIM=0
FOR
SET PSAIM=$ORDER(^PSDRUG(PSADRUG,441,PSAIM))
if PSAIM="B"
QUIT
SET PSAI=$PIECE(^PSDRUG(PSADRUG,441,PSAIM,0),U)
if $$DESCR^PRCPUX1(0,PSAI)]""
Begin DoDot:1
+1 WRITE !,PSAI_" "_$$DESCR^PRCPUX1(0,PSAI)_" ",$$VENNAME^PRCPUX1($PIECE($GET(^PRC(441,+PSAI,0)),U,4)_"PRC(440"),!
End DoDot:1
QUES1 IF $DATA(PSAI)
SET DIR(0)="Y"
SET DIR("A")="Would you like to alter the link(s)"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if Y<1&('$DATA(PSALOC))
GOTO AGAIN
if Y<1
GOTO QUIT
+1 WRITE !!,"Current potential ITEM MASTER file links based on NDC or FSN are:",!!
+2 ;Attempt match by NDC between #50/#441
NDC IF $PIECE($GET(^PSDRUG(PSADRUG,2)),U,4)]""
SET PSANDC=$PIECE(^(2),U,4)
SET PSAI=$$ITEM^PSAUTL(PSANDC)
WRITE "DRUG file NDC: "_PSANDC
+1 IF $DATA(PSAI)
IF $DATA(PSANDC)
IF PSAI
WRITE ?40,"ITEM NUMBER: "_PSAI,!!,"DESC: "_$$DESCR^PRCPUX1(0,PSAI),!
if $GET(^PRC(441,+PSAI,3))
WRITE !?60,"* Inactive item"
if $ORDER(^PRC(441,"F",PSANDC,PSAI))
Begin DoDot:1
MORE SET PSAZ=1
SET PSAI(PSAZ)=PSAI
FOR
SET PSAI(PSAZ)=$ORDER(^PRC(441,"F",PSANDC,PSAI(PSAZ)))
if PSAI(PSAZ)=""
QUIT
WRITE !?40,"ITEM NUMBER: "_PSAI(PSAZ),!!,"DESC: ",$$DESCR^PRCPUX1(0,PSAI(PSAZ))
if $GET(^PRC(441,+PSAI(PSAZ),3))
WRITE !?60,"* Inactive item"
End DoDot:1
+1 ;Attempt match between FSN (#50) and NSN (#441)
FSN IF '$GET(PSAI)
IF $PIECE(^PSDRUG(PSADRUG,0),U,6)]""
SET PSAFSN=$PIECE(^(0),U,6)
if $DATA(^PRC(441,"BB",PSAFSN))
Begin DoDot:1
+1 SET PSAI=$ORDER(^PRC(441,"BB",PSAFSN,""))
WRITE " NO NDC MATCH IN ITEM MASTER file.",!!,"DRUG file FSN: "_PSAFSN,?40,"ITEM NUMBER: "_PSAI,!!,"DESC: ",$$DESCR^PRCPUX1(0,PSAI),!
End DoDot:1
FAIL if '$DATA(PSAI)
SET PSAI=""
if PSAI']""
WRITE !!,"No NDC or FSN match in the ITEM MASTER file.",!
+1 ;S:'$D(^PSDRUG(+PSADRUG,441,0)) ^(0)="^50.0441P^^" ;Removed by SQA recommendation (PSA*3*18)
CON SET DIE="^PSDRUG("
SET DA=PSADRUG
SET DR="441//^S X=$G(PSAI)"
DO ^DIE
KILL DIE
IF $DATA(Y)!($DATA(DTOUT))
SET DIRUT=1
GOTO QUIT
+1 IF '$DATA(^PSDRUG(PSADRUG,"ND"))
WRITE !!,"No NDF link, can't help.",!
GOTO AGAIN
+2 IF $PIECE(^PSDRUG(PSADRUG,"ND"),U)']""
WRITE !!,"No NDF link, can't help.",!
KILL DUOUT
GOTO AGAIN
+3 ;Check for package size or type = OTHER
+4 IF $PIECE($GET(^PSDRUG(+PSADRUG,"ND")),U,4)=2058
WRITE !!,"No matching PACKAGE SIZE in the National Drug File."
GOTO AGAIN
+5 IF $PIECE($GET(^PSDRUG(+PSADRUG,"ND")),U,5)=623
WRITE !!,"No matching PACKAGE TYPE in the National Drug file."
GOTO AGAIN
NDF ;Offer NDF path
+1 WRITE !!,"This drug is linked to the NATIONAL DRUG file.",!!,"There may be an NDC there that will link to the ITEM MASTER file.",!
+2 SET DIR(0)="Y"
SET DIR("A")="Would you like to check"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y<1)
GOTO AGAIN
+3 ;
+4 ;DAVE B (PSA*3*18) Old NDF globals no longer used.
+5 SET PSAVP=$PIECE($GET(^PSDRUG(PSADRUG,"ND")),"^",3)
IF $GET(PSAVP)=""
WRITE !,"Sorry, there is no entry in the PSNDF VA PRODUCT NAME, cannot find match.",!
GOTO AGAIN
+6 ;Call PSNAPIS
+7 SET X=$$CIRN2^PSNAPIS("",PSAVP,.PSANDF)
+8 SET PSX=""
FOR
SET PSX=$ORDER(PSANDF(PSX))
if PSX=""
QUIT
KILL PSA
Begin DoDot:1
+9 IF PSX'["-"
SET PSAOLD=$GET(PSANDC)
SET PSANDC=PSX
DO PSANDC1^PSAHELP
SET PSA=PSANDCX
KILL PSANDCX
IF $GET(PSAOLD)'=""
SET PSANDC=PSAOLD
KILL PSAOLD
+10 IF $GET(PSA)=""
SET PSA=PSX
+11 WRITE !,"Going to check NDC #"_PSA,!
SET DIR(0)="Y"
SET DIR("A")="OK"
SET DIR("B")="No"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!(Y<1)
QUIT
End DoDot:1
if Y<1
QUIT
DO BINGO
AGAIN KILL PSA,PSAD,PSADO,PSADRUG,PSAF,PSAFSN,PSANDC,PSANDF,PSAI,PSAIM,PSAIQ,PSAIQT,PSAIAC,PSAILC,PSAINV,PSAINVN,PSAP,PSAPB,PSAS,PSAT,PSATB,PSAU,PSAV,PSAZ,X,Y
+1 if $DATA(PSAS)!($DATA(PSALOC))
QUIT
WRITE !
SET DIR(0)="Y"
SET DIR("A")="Another drug"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
IF Y>0
KILL PSAIT,PSAI
GOTO START
QUIT if '$GET(PSAIT(1))
NEW PSAIT,Y
KILL PSA,PSAI,PSAD,PSADO,PSADRUG,PSAF,PSAFSN,PSANDC,PSANDF,PSAI,PSAIM,PSAIQ,PSAIQT,PSAIAC,PSAILC,PSAINV,PSAINVN,PSAP,PSAPB,PSAS,PSAT,PSATB,PSAU,PSAV,PSAZ,X,Y
QUIT
BINGO SET PSAI=$ORDER(^PRC(441,"F",PSA,""))
+1 if $ORDER(^PSDRUG("AB",+PSAI,0))
QUIT
+2 WRITE !!,"DRUG file: "_$PIECE(^PSDRUG(PSADRUG,0),U),!!,"Item #: "_PSAI," Desc: ",$$DESCR^PRCPUX1(0,PSAI),!
Begin DoDot:1
+3 SET DIR(0)="Y"
SET DIR("A")="OK to link"
SET DIR("B")="Yes"
SET DIR("?")="If yes, I'll perform the link"
DO ^DIR
KILL DIR
if (Y=0)
KILL Y
if ($GET(Y)<1)
QUIT
+4 SET DIE=50
SET DA=PSADRUG
SET DR="441///^S X=""`""_PSAI"
DO ^DIE
WRITE " linked."
End DoDot:1
+5 QUIT
