PSSAUTL.m

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)

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)