PSAPOST.m

PSAPOST ;BIR/JMB-Post Init ;7/23/97

 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97

 ;If there is a NDC in field #31, the NDC is added to the SYNONYM

 ;multiple.

 ;

SYNONYM D BMES^XPDUTL("Copying the NDCs to the SYNONYM multiple in the DRUG file.")

 S PSAIEN=0 F  S PSAIEN=$O(^PSDRUG(PSAIEN)) Q:'PSAIEN  D

 .Q:$P($G(^PSDRUG(PSAIEN,2)),"^",4)=""

 .S PSANDC4=$P($G(^PSDRUG(PSAIEN,2)),"^",4)

 .S PSANDC=$E("000000",1,(6-$L($P(PSANDC4,"-"))))_$P(PSANDC4,"-")_$E("0000",1,(4-$L($P(PSANDC4,"-",2))))_$P(PSANDC4,"-",2)_$E("00",1,(2-$L($P(PSANDC4,"-",3))))_$P(PSANDC4,"-",3)

 .S PSADASH=$E("000000",1,(6-$L($P(PSANDC4,"-"))))_$P(PSANDC4,"-")_"-"_$E("0000",1,(4-$L($P(PSANDC4,"-",2))))_$P(PSANDC4,"-",2)_"-"_$E("00",1,(2-$L($P(PSANDC4,"-",3))))_$P(PSANDC4,"-",3)

 .I '$D(^PSDRUG(PSAIEN,1,0)) S ^PSDRUG(PSAIEN,1,0)="^50.1A^^"

 .K DD,DO,DA S DA(1)=PSAIEN,DIC="^PSDRUG("_DA(1)_",1,",DIC(0)="LM",X=PSANDC,DLAYGO=50 D ^DIC K DIC,DLAYGO

 .Q:$G(DA)=""

 .S DR="2///"_PSADASH_";1///D",DA=+Y,DIE="^PSDRUG("_DA(1)_",1,"

 .F  L +^PSDRUG(PSAIEN,0):0 I  Q

 .D ^DIE K DIE L -^PSDRUG(PSAIEN,0)

 K DA,DIC,DIE,DR,PSADASH,PSAIEN,PSANDC,PSANDC4,X,Y

 D BMES^XPDUTL("Copying NDCs is complete!")

 Q

PSAPOST   ;BIR/JMB-Post Init ;7/23/97

 +1       ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;; 10/24/97

 +2       ;If there is a NDC in field #31, the NDC is added to the SYNONYM

 +3       ;multiple.

 +4       ;

SYNONYM    DO BMES^XPDUTL("Copying the NDCs to the SYNONYM multiple in the DRUG file.")

 +1        SET PSAIEN=0

           FOR 

               SET PSAIEN=$ORDER(^PSDRUG(PSAIEN))

               IF 'PSAIEN

                   QUIT 

               Begin DoDot:1

 +2                IF $PIECE($GET(^PSDRUG(PSAIEN,2)),"^",4)=""

                       QUIT 

 +3                SET PSANDC4=$PIECE($GET(^PSDRUG(PSAIEN,2)),"^",4)

 +4                SET PSANDC=$EXTRACT("000000",1,(6-$LENGTH($PIECE(PSANDC4,"-"))))_$PIECE(PSANDC4,"-")_$EXTRACT("0000",1,(4-$LENGTH($PIECE(PSANDC4,"-",2))))_$PIECE(PSANDC4,"-",2)_$EXTRACT("00",1,(2-$LENGTH($PIECE(PSANDC4,"-",3))))_$PIECE(PSANDC4,"-",3)

 +5                SET PSADASH=$EXTRACT("000000",1,(6-$LENGTH($PIECE(PSANDC4,"-"))))_$PIECE(PSANDC4,"-")_"-"_$EXTRACT("0000",1,(4-$LENGTH($PIECE(PSANDC4,"-",2))))_$PIECE(PSANDC4,"-",2)_"-"_$EXTRACT("00",1,(2-$LENGTH($PIECE(PSANDC4,"-",3))))_$PIECE(PSANDC4

,"-",3)

 +6                IF '$DATA(^PSDRUG(PSAIEN,1,0))

                       SET ^PSDRUG(PSAIEN,1,0)="^50.1A^^"

 +7                KILL DD,DO,DA

                   SET DA(1)=PSAIEN

                   SET DIC="^PSDRUG("_DA(1)_",1,"

                   SET DIC(0)="LM"

                   SET X=PSANDC

                   SET DLAYGO=50

                   DO ^DIC

                   KILL DIC,DLAYGO

 +8                IF $GET(DA)=""

                       QUIT 

 +9                SET DR="2///"_PSADASH_";1///D"

                   SET DA=+Y

                   SET DIE="^PSDRUG("_DA(1)_",1,"

 +10               FOR 

                       LOCK +^PSDRUG(PSAIEN,0):0

                      IF $TEST

                           QUIT 

 +11               DO ^DIE

                   KILL DIE

                   LOCK -^PSDRUG(PSAIEN,0)

               End DoDot:1

 +12       KILL DA,DIC,DIE,DR,PSADASH,PSAIEN,PSANDC,PSANDC4,X,Y

 +13       DO BMES^XPDUTL("Copying NDCs is complete!")

 +14       QUIT