PSSPOI ;BIR/RLW-CREATE PHARMACY ORDERABLE ITEMS ; 09/01/98 7:10
;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
EN ;
; variable prefixes: ADD=iv additive file SOL=iv solution file
; PD=primary drug file DD=dispense drug file
; NDF=national drug file DF=NDF dosage form
; SPD=pharmacy orderable item file SYN=synonym
;
LIVE ; populate PHARMACY ORDERABLE ITEM file, tie dispense drug to it
; loop thru ^TMP global to build 50.7
N J,ADDIEN,ADDNAME,DDIEN,DDNAME,PDIEN,PDNAME,PDNAMEDF,NDF,NDFVA,DF,DFNAME,SPDNAME,X,PSMATCH,SOLIEN,SOLNAME,SPD,SPDFN,SYNIEN,SYNONYM
S PDNAMEDF="" F S PDNAMEDF=$O(^TMP("PSSD",$J,PDNAMEDF)) Q:PDNAMEDF="" S DFNAME=$P(PDNAMEDF,"~",2),PDNAME=$P(PDNAMEDF,"~") Q:DFNAME="" S (DF,DDNAME,SPDNAME)="",DF=$O(^PS(50.606,"B",DFNAME,DF)) D
.F I=$L(PDNAME):-1:1 Q:$E(PDNAME,I)'=" "
.S SPDNAME=$E(PDNAME,1,I)
.S Y=-1,SPDIEN="" I '$D(^PS(50.7,"ADF",SPDNAME,DF)) S DIC="^PS(50.7,",DIC(0)="L",DIC("DR")=".02////"_DF,X=SPDNAME K DD,DO D FILE^DICN K DIC S:+Y>0 SPDIEN=+Y
.S:'SPDIEN SPDIEN=$O(^PS(50.7,"ADF",SPDNAME,DF,SPDIEN))
.S SYNIEN=0,PDIEN="",PDIEN=$O(^PS(50.3,"B",PDNAME,PDIEN)) Q:PDIEN="" D
..S Y=0,Y=$O(^PS(50.3,PDIEN,1,"B","U",Y)) S:Y Y=$G(^PS(50.3,PDIEN,1,Y,0)),$P(^PS(50.7,SPDIEN,0),"^",5,8)=$P(Y,"^",5,8)
..S SYNIEN=$O(^PS(50.3,PDIEN,2,SYNIEN)) Q:'SYNIEN I '$D(^PS(50.7,SPDIEN,2,0)) S ^(0)="^50.72^1^1",SYNONYM=$G(^PS(50.3,PDIEN,2,SYNIEN,0)),^PS(50.7,SPDIEN,2,1,0)=SYNONYM,J=1,^PS(50.7,SPDIEN,2,"B",SYNONYM,J)=""
..I SYNIEN F S SYNIEN=$O(^PS(50.3,PDIEN,2,SYNIEN)) Q:'SYNIEN S J=J+1,SYNONYM=$G(^PS(50.3,PDIEN,2,SYNIEN,0)),^PS(50.7,SPDIEN,2,J,0)=SYNONYM,^PS(50.7,SPDIEN,2,"B",SYNONYM,J)="" F I=3,4 S $P(^PS(50.7,SPDIEN,2,0),"^",3,4)=J_"^"_J
.I SPDIEN F S DDNAME=$O(^TMP("PSSD",$J,PDNAMEDF,DDNAME)) Q:DDNAME="" S DDIEN="",DDIEN=$O(^PSDRUG("B",DDNAME,DDIEN)) Q:'DDIEN S DIE="^PSDRUG(",DA=DDIEN,DR="2.1////"_SPDIEN D ^DIE K DIE
.Q
;
IVADD ; populate IV Additives, Solutions
S X1=DT,X2=-365 D C^%DTC S PIND=X K X1,X2
;***********DON'T EVEN USE TMP GLOBAL ************
F ADDIEN=0:0 S ADDIEN=$O(^PS(52.6,ADDIEN)) Q:'ADDIEN S DDIEN=+$P($G(^PS(52.6,ADDIEN,0)),"^",2) I DDIEN,$D(^PSDRUG(DDIEN,0)) D
.S NDND=$G(^PSDRUG(DDIEN,"ND")) Q:'$P(NDND,"^")!('$P(NDND,"^",3))
.S DA=$P(NDND,"^",1),K=$P(NDND,"^",3),X=$$PSJDF^PSNAPIS(DA,K) Q:'X
.S DFPTR=+$P(X,"^") Q:'DFPTR!('$D(^PS(50.606,+DFPTR,0)))
.S ADDNAME=$P($G(^PS(52.6,ADDIEN,0)),"^") Q:ADDNAME=""
.S PDT=+$P($G(^PS(52.6,ADDIEN,"I")),"^") I PDT,PDT<PIND Q
.S AAAFLAG=0 F AAA=0:0 S AAA=$O(^PS(50.7,"ADF",ADDNAME,DFPTR,AAA)) Q:'AAA!(AAAFLAG) S:$P($G(^PS(50.7,AAA,0)),"^",3) AAAFLAG=1
.Q:AAAFLAG
.S DIC="^PS(50.7,",X=ADDNAME,DIC(0)="L",DIC("DR")=".02////"_DFPTR_";.03////1" K DD,DO D FILE^DICN K DIC S SPDIEN=+Y
.Q:'SPDIEN
.K DIE S DIE="^PS(52.6,",DA=ADDIEN,DR="15////"_SPDIEN D ^DIE K DIE
.;NOW, LOOP THRU 3 NODE FOR SYNONYM
.S AAACT=0 F AAA=0:0 S AAA=$O(^PS(52.6,ADDIEN,3,AAA)) Q:'AAA S SYNONYM=$P($G(^(AAA,0)),"^") I SYNONYM'="" S AAACT=AAACT+1 D
..S ^PS(50.7,SPDIEN,2,AAACT,0)=SYNONYM,^PS(50.7,SPDIEN,2,"B",SYNONYM,AAACT)=""
.I AAACT S ^PS(50.7,SPDIEN,2,0)="^50.72^"_AAACT_"^"_AAACT
K PIND,PDT
;
IVSOL ;
;****************DON'T EVEN USE TMP GLOBAL **********
;DO SAME AS ADDITIVES, BUT IF DATAISIN ADF WITH A ONE, MATCH AND DO SYN, IF NOT CREATE,MATCH AND DO SYN
F SOLIEN=0:0 S SOLIEN=$O(^PS(52.7,SOLIEN)) Q:'SOLIEN S DDIEN=+$P($G(^PS(52.7,SOLIEN,0)),"^",2) I DDIEN,$D(^PSDRUG(DDIEN,0)) D
.S NDND=$G(^PSDRUG(DDIEN,"ND")) Q:'$P(NDND,"^")!('$P(NDND,"^",3))
.S DA=$P(NDND,"^",1),K=$P(NDND,"^",3),X=$$PSJDF^PSNAPIS(DA,K) Q:'X
.S DFPTR=+$P(X,"^") Q:'DFPTR!('$D(^PS(50.606,+DFPTR,0)))
.S SOLNAME=$P($G(^PS(52.7,SOLIEN,0)),"^") Q:SOLNAME=""
.S (AAAFLAG,AAAMATCH)=0 F AAA=0:0 S AAA=$O(^PS(50.7,"ADF",SOLNAME,DFPTR,AAA)) Q:'AAA!(AAAFLAG) I $P($G(^PS(50.7,AAA,0)),"^",3) S AAAFLAG=1,AAAMATCH=AAA
.I AAAFLAG D
..K DIE S DIE="^PS(52.7,",DA=SOLIEN,DR="9////"_AAAMATCH D ^DIE K DIE
..F AAA=0:0 S AAA=$O(^PS(52.7,SOLIEN,3,AAA)) Q:'AAA S SYNONYM=$P($G(^(AAA,0)),"^") I SYNONYM'="",'$O(^PS(50.7,AAAMATCH,2,"B",SYNONYM,0)) D
...S AAACT=0 F SYCT=0:0 S SYCT=$O(^PS(50.7,AAAMATCH,2,SYCT)) Q:'SYCT S AAACT=SYCT
...S AAACT=AAACT+1,^PS(50.7,AAAMATCH,2,AAACT,0)=SYNONYM,^PS(50.7,AAAMATCH,2,"B",SYNONYM,AAACT)=""
.I AAAFLAG S ATOTAL=0 F AAACT=0:0 S AAACT=$O(^PS(50.7,AAAMATCH,2,AAACT)) Q:'AAACT S ATOTAL=ATOTAL+1
.I AAAFLAG,ATOTAL S ^PS(50.7,AAAMATCH,2,0)="^50.72^"_ATOTAL_"^"_ATOTAL
.I 'AAAFLAG D
..K DIC S DIC="^PS(50.7,",X=SOLNAME,DIC(0)="L",DIC("DR")=".02////"_DFPTR_";.03////1" K DD,DO D FILE^DICN K DIC S SPDIEN=+Y
..Q:'SPDIEN
..K DIE S DIE="^PS(52.7,",DA=SOLIEN,DR="9////"_SPDIEN D ^DIE K DIE
..S AAACT=0 F AAA=0:0 S AAA=$O(^PS(52.7,SOLIEN,3,AAA)) Q:'AAA S SYNONYM=$P($G(^(AAA,0)),"^") I SYNONYM'="" S AAACT=AAACT+1 D
...S ^PS(50.7,SPDIEN,2,AAACT,0)=SYNONYM,^PS(50.7,SPDIEN,2,"B",SYNONYM,AAACT)=""
..I AAACT S ^PS(50.7,SPDIEN,2,0)="^50.72^"_AAACT_"^"_AAACT
;FOR SYN, CHECK FOR NOT ALREADY EXISTING!!
;
XREF ; do next line to xref whole file after looping thru ^TMP to populate
;******************DON'T EVEN DO THIS *******************
;I $D(PSLOAD) S DIK="^PS(50.7," D IXALL^DIK K DIK
Q
;
DUPL ; see if there's already an orderable item with the same name and dosage form
N OLDDF S SPDIEN="" F S SPDIEN=$O(^PS(50.7,"B",SOLNAME,SPDIEN)) Q:SPDIEN="" S OLDDF=$P(^PS(50.7,SPDIEN,0),"^",2) I OLDDF=DF S ^PS(50.7,"AIV",1,SOLIEN)="" Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPOI 5501 printed Sep 23, 2025@20:09:40 Page 2
PSSPOI ;BIR/RLW-CREATE PHARMACY ORDERABLE ITEMS ; 09/01/98 7:10
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
EN ;
+1 ; variable prefixes: ADD=iv additive file SOL=iv solution file
+2 ; PD=primary drug file DD=dispense drug file
+3 ; NDF=national drug file DF=NDF dosage form
+4 ; SPD=pharmacy orderable item file SYN=synonym
+5 ;
LIVE ; populate PHARMACY ORDERABLE ITEM file, tie dispense drug to it
+1 ; loop thru ^TMP global to build 50.7
+2 NEW J,ADDIEN,ADDNAME,DDIEN,DDNAME,PDIEN,PDNAME,PDNAMEDF,NDF,NDFVA,DF,DFNAME,SPDNAME,X,PSMATCH,SOLIEN,SOLNAME,SPD,SPDFN,SYNIEN,SYNONYM
+3 SET PDNAMEDF=""
FOR
SET PDNAMEDF=$ORDER(^TMP("PSSD",$JOB,PDNAMEDF))
if PDNAMEDF=""
QUIT
SET DFNAME=$PIECE(PDNAMEDF,"~",2)
SET PDNAME=$PIECE(PDNAMEDF,"~")
if DFNAME=""
QUIT
SET (DF,DDNAME,SPDNAME)=""
SET DF=$ORDER(^PS(50.606,"B",DFNAME,DF))
Begin DoDot:1
+4 FOR I=$LENGTH(PDNAME):-1:1
if $EXTRACT(PDNAME,I)'=" "
QUIT
+5 SET SPDNAME=$EXTRACT(PDNAME,1,I)
+6 SET Y=-1
SET SPDIEN=""
IF '$DATA(^PS(50.7,"ADF",SPDNAME,DF))
SET DIC="^PS(50.7,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_DF
SET X=SPDNAME
KILL DD,DO
DO FILE^DICN
KILL DIC
if +Y>0
SET SPDIEN=+Y
+7 if 'SPDIEN
SET SPDIEN=$ORDER(^PS(50.7,"ADF",SPDNAME,DF,SPDIEN))
+8 SET SYNIEN=0
SET PDIEN=""
SET PDIEN=$ORDER(^PS(50.3,"B",PDNAME,PDIEN))
if PDIEN=""
QUIT
Begin DoDot:2
+9 SET Y=0
SET Y=$ORDER(^PS(50.3,PDIEN,1,"B","U",Y))
if Y
SET Y=$GET(^PS(50.3,PDIEN,1,Y,0))
SET $PIECE(^PS(50.7,SPDIEN,0),"^",5,8)=$PIECE(Y,"^",5,8)
+10 SET SYNIEN=$ORDER(^PS(50.3,PDIEN,2,SYNIEN))
if 'SYNIEN
QUIT
IF '$DATA(^PS(50.7,SPDIEN,2,0))
SET ^(0)="^50.72^1^1"
SET SYNONYM=$GET(^PS(50.3,PDIEN,2,SYNIEN,0))
SET ^PS(50.7,SPDIEN,2,1,0)=SYNONYM
SET J=1
SET ^PS(50.7,SPDIEN,2,"B",SYNONYM,J)=""
+11 IF SYNIEN
FOR
SET SYNIEN=$ORDER(^PS(50.3,PDIEN,2,SYNIEN))
if 'SYNIEN
QUIT
SET J=J+1
SET SYNONYM=$GET(^PS(50.3,PDIEN,2,SYNIEN,0))
SET ^PS(50.7,SPDIEN,2,J,0)=SYNONYM
SET ^PS(50.7,SPDIEN,2,"B",SYNONYM,J)=""
FOR I=3,4
SET $PIECE(^PS(50.7,SPDIEN,2,0),"^",3,4)=J_"^"_J
End DoDot:2
+12 IF SPDIEN
FOR
SET DDNAME=$ORDER(^TMP("PSSD",$JOB,PDNAMEDF,DDNAME))
if DDNAME=""
QUIT
SET DDIEN=""
SET DDIEN=$ORDER(^PSDRUG("B",DDNAME,DDIEN))
if 'DDIEN
QUIT
SET DIE="^PSDRUG("
SET DA=DDIEN
SET DR="2.1////"_SPDIEN
DO ^DIE
KILL DIE
+13 QUIT
End DoDot:1
+14 ;
IVADD ; populate IV Additives, Solutions
+1 SET X1=DT
SET X2=-365
DO C^%DTC
SET PIND=X
KILL X1,X2
+2 ;***********DON'T EVEN USE TMP GLOBAL ************
+3 FOR ADDIEN=0:0
SET ADDIEN=$ORDER(^PS(52.6,ADDIEN))
if 'ADDIEN
QUIT
SET DDIEN=+$PIECE($GET(^PS(52.6,ADDIEN,0)),"^",2)
IF DDIEN
IF $DATA(^PSDRUG(DDIEN,0))
Begin DoDot:1
+4 SET NDND=$GET(^PSDRUG(DDIEN,"ND"))
if '$PIECE(NDND,"^")!('$PIECE(NDND,"^",3))
QUIT
+5 SET DA=$PIECE(NDND,"^",1)
SET K=$PIECE(NDND,"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
if 'X
QUIT
+6 SET DFPTR=+$PIECE(X,"^")
if 'DFPTR!('$DATA(^PS(50.606,+DFPTR,0)))
QUIT
+7 SET ADDNAME=$PIECE($GET(^PS(52.6,ADDIEN,0)),"^")
if ADDNAME=""
QUIT
+8 SET PDT=+$PIECE($GET(^PS(52.6,ADDIEN,"I")),"^")
IF PDT
IF PDT<PIND
QUIT
+9 SET AAAFLAG=0
FOR AAA=0:0
SET AAA=$ORDER(^PS(50.7,"ADF",ADDNAME,DFPTR,AAA))
if 'AAA!(AAAFLAG)
QUIT
if $PIECE($GET(^PS(50.7,AAA,0)),"^",3)
SET AAAFLAG=1
+10 if AAAFLAG
QUIT
+11 SET DIC="^PS(50.7,"
SET X=ADDNAME
SET DIC(0)="L"
SET DIC("DR")=".02////"_DFPTR_";.03////1"
KILL DD,DO
DO FILE^DICN
KILL DIC
SET SPDIEN=+Y
+12 if 'SPDIEN
QUIT
+13 KILL DIE
SET DIE="^PS(52.6,"
SET DA=ADDIEN
SET DR="15////"_SPDIEN
DO ^DIE
KILL DIE
+14 ;NOW, LOOP THRU 3 NODE FOR SYNONYM
+15 SET AAACT=0
FOR AAA=0:0
SET AAA=$ORDER(^PS(52.6,ADDIEN,3,AAA))
if 'AAA
QUIT
SET SYNONYM=$PIECE($GET(^(AAA,0)),"^")
IF SYNONYM'=""
SET AAACT=AAACT+1
Begin DoDot:2
+16 SET ^PS(50.7,SPDIEN,2,AAACT,0)=SYNONYM
SET ^PS(50.7,SPDIEN,2,"B",SYNONYM,AAACT)=""
End DoDot:2
+17 IF AAACT
SET ^PS(50.7,SPDIEN,2,0)="^50.72^"_AAACT_"^"_AAACT
End DoDot:1
+18 KILL PIND,PDT
+19 ;
IVSOL ;
+1 ;****************DON'T EVEN USE TMP GLOBAL **********
+2 ;DO SAME AS ADDITIVES, BUT IF DATAISIN ADF WITH A ONE, MATCH AND DO SYN, IF NOT CREATE,MATCH AND DO SYN
+3 FOR SOLIEN=0:0
SET SOLIEN=$ORDER(^PS(52.7,SOLIEN))
if 'SOLIEN
QUIT
SET DDIEN=+$PIECE($GET(^PS(52.7,SOLIEN,0)),"^",2)
IF DDIEN
IF $DATA(^PSDRUG(DDIEN,0))
Begin DoDot:1
+4 SET NDND=$GET(^PSDRUG(DDIEN,"ND"))
if '$PIECE(NDND,"^")!('$PIECE(NDND,"^",3))
QUIT
+5 SET DA=$PIECE(NDND,"^",1)
SET K=$PIECE(NDND,"^",3)
SET X=$$PSJDF^PSNAPIS(DA,K)
if 'X
QUIT
+6 SET DFPTR=+$PIECE(X,"^")
if 'DFPTR!('$DATA(^PS(50.606,+DFPTR,0)))
QUIT
+7 SET SOLNAME=$PIECE($GET(^PS(52.7,SOLIEN,0)),"^")
if SOLNAME=""
QUIT
+8 SET (AAAFLAG,AAAMATCH)=0
FOR AAA=0:0
SET AAA=$ORDER(^PS(50.7,"ADF",SOLNAME,DFPTR,AAA))
if 'AAA!(AAAFLAG)
QUIT
IF $PIECE($GET(^PS(50.7,AAA,0)),"^",3)
SET AAAFLAG=1
SET AAAMATCH=AAA
+9 IF AAAFLAG
Begin DoDot:2
+10 KILL DIE
SET DIE="^PS(52.7,"
SET DA=SOLIEN
SET DR="9////"_AAAMATCH
DO ^DIE
KILL DIE
+11 FOR AAA=0:0
SET AAA=$ORDER(^PS(52.7,SOLIEN,3,AAA))
if 'AAA
QUIT
SET SYNONYM=$PIECE($GET(^(AAA,0)),"^")
IF SYNONYM'=""
IF '$ORDER(^PS(50.7,AAAMATCH,2,"B",SYNONYM,0))
Begin DoDot:3
+12 SET AAACT=0
FOR SYCT=0:0
SET SYCT=$ORDER(^PS(50.7,AAAMATCH,2,SYCT))
if 'SYCT
QUIT
SET AAACT=SYCT
+13 SET AAACT=AAACT+1
SET ^PS(50.7,AAAMATCH,2,AAACT,0)=SYNONYM
SET ^PS(50.7,AAAMATCH,2,"B",SYNONYM,AAACT)=""
End DoDot:3
End DoDot:2
+14 IF AAAFLAG
SET ATOTAL=0
FOR AAACT=0:0
SET AAACT=$ORDER(^PS(50.7,AAAMATCH,2,AAACT))
if 'AAACT
QUIT
SET ATOTAL=ATOTAL+1
+15 IF AAAFLAG
IF ATOTAL
SET ^PS(50.7,AAAMATCH,2,0)="^50.72^"_ATOTAL_"^"_ATOTAL
+16 IF 'AAAFLAG
Begin DoDot:2
+17 KILL DIC
SET DIC="^PS(50.7,"
SET X=SOLNAME
SET DIC(0)="L"
SET DIC("DR")=".02////"_DFPTR_";.03////1"
KILL DD,DO
DO FILE^DICN
KILL DIC
SET SPDIEN=+Y
+18 if 'SPDIEN
QUIT
+19 KILL DIE
SET DIE="^PS(52.7,"
SET DA=SOLIEN
SET DR="9////"_SPDIEN
DO ^DIE
KILL DIE
+20 SET AAACT=0
FOR AAA=0:0
SET AAA=$ORDER(^PS(52.7,SOLIEN,3,AAA))
if 'AAA
QUIT
SET SYNONYM=$PIECE($GET(^(AAA,0)),"^")
IF SYNONYM'=""
SET AAACT=AAACT+1
Begin DoDot:3
+21 SET ^PS(50.7,SPDIEN,2,AAACT,0)=SYNONYM
SET ^PS(50.7,SPDIEN,2,"B",SYNONYM,AAACT)=""
End DoDot:3
+22 IF AAACT
SET ^PS(50.7,SPDIEN,2,0)="^50.72^"_AAACT_"^"_AAACT
End DoDot:2
End DoDot:1
+23 ;FOR SYN, CHECK FOR NOT ALREADY EXISTING!!
+24 ;
XREF ; do next line to xref whole file after looping thru ^TMP to populate
+1 ;******************DON'T EVEN DO THIS *******************
+2 ;I $D(PSLOAD) S DIK="^PS(50.7," D IXALL^DIK K DIK
+3 QUIT
+4 ;
DUPL ; see if there's already an orderable item with the same name and dosage form
+1 NEW OLDDF
SET SPDIEN=""
FOR
SET SPDIEN=$ORDER(^PS(50.7,"B",SOLNAME,SPDIEN))
if SPDIEN=""
QUIT
SET OLDDF=$PIECE(^PS(50.7,SPDIEN,0),"^",2)
IF OLDDF=DF
SET ^PS(50.7,"AIV",1,SOLIEN)=""
QUIT
+2 QUIT
