PSSAUTL ;BIR/LTL-Utility Routine for FM functions ; 09/02/97 8:28
;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97
DALINK ;check for Primary already linked to DA location
I $O(^PSD(58.8,"P",X,0)) W $C(7),!!,$P($G(^PSD(58.8,+$O(^PSD(58.8,"P",X,0)),0)),U)," is already linked to ",$$INVNAME^PRCPUX1(X) K X Q
Q
FI N PSA S PSA=$O(^PSDRUG("AB",+X,0)) S:PSA=DA PSA=$O(^(DA)) W:$G(PSA) $C(7),!!,$P($G(^PSDRUG(+$O(^PSDRUG("AB",+X,"")),0)),U)," is already linked to",!!,"Item #",X," ",$$DESCR^PRCPUX1(0,X) S:$G(PSA) X="" Q
;
ITEM(PSA) ;return Item Master # ^PRC(441
;PSA = NDC from ^PSDRUG(
S PSA(1)=$O(^PRC(441,"F",PSA,0))
D:'PSA(1)
.S:$L($P(PSA,"-"))<6 PSA(1)=$O(^PRC(441,"F",0_PSA,0))
.S:'PSA(1)&($L($P(PSA,"-"))=4) PSA(1)=$O(^PRC(441,"F","00"_PSA,0))
.I 'PSA(1),'$E(PSA),$L($P(PSA,"-"))>4 S PSA(1)=$O(^PRC(441,"F",$E(PSA,2,14),0))
.I 'PSA(1),'$E(PSA,1,2),$L($P(PSA,"-"))=6 S PSA(1)=$O(^PRC(441,"F",$E(PSA,3,14),0))
Q PSA(1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSAUTL 939 printed Dec 13, 2024@02:30:24 Page 2
PSSAUTL ;BIR/LTL-Utility Routine for FM functions ; 09/02/97 8:28
+1 ;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97
DALINK ;check for Primary already linked to DA location
+1 IF $ORDER(^PSD(58.8,"P",X,0))
WRITE $CHAR(7),!!,$PIECE($GET(^PSD(58.8,+$ORDER(^PSD(58.8,"P",X,0)),0)),U)," is already linked to ",$$INVNAME^PRCPUX1(X)
KILL X
QUIT
+2 QUIT
FI NEW PSA
SET PSA=$ORDER(^PSDRUG("AB",+X,0))
if PSA=DA
SET PSA=$ORDER(^(DA))
if $GET(PSA)
WRITE $CHAR(7),!!,$PIECE($GET(^PSDRUG(+$ORDER(^PSDRUG("AB",+X,"")),0)),U)," is already linked to",!!,"Item #",X," ",$$DESCR^PRCPUX1(0,X)
if $GET(PSA)
SET X=""
QUIT
+1 ;
ITEM(PSA) ;return Item Master # ^PRC(441
+1 ;PSA = NDC from ^PSDRUG(
+2 SET PSA(1)=$ORDER(^PRC(441,"F",PSA,0))
+3 if 'PSA(1)
Begin DoDot:1
+4 if $LENGTH($PIECE(PSA,"-"))<6
SET PSA(1)=$ORDER(^PRC(441,"F",0_PSA,0))
+5 if 'PSA(1)&($LENGTH($PIECE(PSA,"-"))=4)
SET PSA(1)=$ORDER(^PRC(441,"F","00"_PSA,0))
+6 IF 'PSA(1)
IF '$EXTRACT(PSA)
IF $LENGTH($PIECE(PSA,"-"))>4
SET PSA(1)=$ORDER(^PRC(441,"F",$EXTRACT(PSA,2,14),0))
+7 IF 'PSA(1)
IF '$EXTRACT(PSA,1,2)
IF $LENGTH($PIECE(PSA,"-"))=6
SET PSA(1)=$ORDER(^PRC(441,"F",$EXTRACT(PSA,3,14),0))
End DoDot:1
+8 QUIT PSA(1)
