PSAPOST ;BIR/JMB-Post Init ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
;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):$S($G(DILOCKTM)>0:DILOCKTM,1:3) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAPOST 1242 printed Nov 22, 2024@17:00:12 Page 2
PSAPOST ;BIR/JMB-Post Init ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
+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):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
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
