- 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
- 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
