source: WorldVistAEHR/trunk/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSPOI.m@ 1430

Last change on this file since 1430 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.3 KB
Line 
1PSSPOI ;BIR/RLW-CREATE PHARMACY ORDERABLE ITEMS ; 09/01/98 7:10
2 ;;1.0;PHARMACY DATA MANAGEMENT;**15**;9/30/97
3EN ;
4 ; variable prefixes: ADD=iv additive file SOL=iv solution file
5 ; PD=primary drug file DD=dispense drug file
6 ; NDF=national drug file DF=NDF dosage form
7 ; SPD=pharmacy orderable item file SYN=synonym
8 ;
9LIVE ; populate PHARMACY ORDERABLE ITEM file, tie dispense drug to it
10 ; loop thru ^TMP global to build 50.7
11 N J,ADDIEN,ADDNAME,DDIEN,DDNAME,PDIEN,PDNAME,PDNAMEDF,NDF,NDFVA,DF,DFNAME,SPDNAME,X,PSMATCH,SOLIEN,SOLNAME,SPD,SPDFN,SYNIEN,SYNONYM
12 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
13 .F I=$L(PDNAME):-1:1 Q:$E(PDNAME,I)'=" "
14 .S SPDNAME=$E(PDNAME,1,I)
15 .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
16 .S:'SPDIEN SPDIEN=$O(^PS(50.7,"ADF",SPDNAME,DF,SPDIEN))
17 .S SYNIEN=0,PDIEN="",PDIEN=$O(^PS(50.3,"B",PDNAME,PDIEN)) Q:PDIEN="" D
18 ..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)
19 ..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)=""
20 ..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
21 .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
22 .Q
23 ;
24IVADD ; populate IV Additives, Solutions
25 S X1=DT,X2=-365 D C^%DTC S PIND=X K X1,X2
26 ;***********DON'T EVEN USE TMP GLOBAL ************
27 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
28 .S NDND=$G(^PSDRUG(DDIEN,"ND")) Q:'$P(NDND,"^")!('$P(NDND,"^",3))
29 .S DA=$P(NDND,"^",1),K=$P(NDND,"^",3),X=$$PSJDF^PSNAPIS(DA,K) Q:'X
30 .S DFPTR=+$P(X,"^") Q:'DFPTR!('$D(^PS(50.606,+DFPTR,0)))
31 .S ADDNAME=$P($G(^PS(52.6,ADDIEN,0)),"^") Q:ADDNAME=""
32 .S PDT=+$P($G(^PS(52.6,ADDIEN,"I")),"^") I PDT,PDT<PIND Q
33 .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
34 .Q:AAAFLAG
35 .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
36 .Q:'SPDIEN
37 .K DIE S DIE="^PS(52.6,",DA=ADDIEN,DR="15////"_SPDIEN D ^DIE K DIE
38 .;NOW, LOOP THRU 3 NODE FOR SYNONYM
39 .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
40 ..S ^PS(50.7,SPDIEN,2,AAACT,0)=SYNONYM,^PS(50.7,SPDIEN,2,"B",SYNONYM,AAACT)=""
41 .I AAACT S ^PS(50.7,SPDIEN,2,0)="^50.72^"_AAACT_"^"_AAACT
42 K PIND,PDT
43 ;
44IVSOL ;
45 ;****************DON'T EVEN USE TMP GLOBAL **********
46 ;DO SAME AS ADDITIVES, BUT IF DATAISIN ADF WITH A ONE, MATCH AND DO SYN, IF NOT CREATE,MATCH AND DO SYN
47 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
48 .S NDND=$G(^PSDRUG(DDIEN,"ND")) Q:'$P(NDND,"^")!('$P(NDND,"^",3))
49 .S DA=$P(NDND,"^",1),K=$P(NDND,"^",3),X=$$PSJDF^PSNAPIS(DA,K) Q:'X
50 .S DFPTR=+$P(X,"^") Q:'DFPTR!('$D(^PS(50.606,+DFPTR,0)))
51 .S SOLNAME=$P($G(^PS(52.7,SOLIEN,0)),"^") Q:SOLNAME=""
52 .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
53 .I AAAFLAG D
54 ..K DIE S DIE="^PS(52.7,",DA=SOLIEN,DR="9////"_AAAMATCH D ^DIE K DIE
55 ..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
56 ...S AAACT=0 F SYCT=0:0 S SYCT=$O(^PS(50.7,AAAMATCH,2,SYCT)) Q:'SYCT S AAACT=SYCT
57 ...S AAACT=AAACT+1,^PS(50.7,AAAMATCH,2,AAACT,0)=SYNONYM,^PS(50.7,AAAMATCH,2,"B",SYNONYM,AAACT)=""
58 .I AAAFLAG S ATOTAL=0 F AAACT=0:0 S AAACT=$O(^PS(50.7,AAAMATCH,2,AAACT)) Q:'AAACT S ATOTAL=ATOTAL+1
59 .I AAAFLAG,ATOTAL S ^PS(50.7,AAAMATCH,2,0)="^50.72^"_ATOTAL_"^"_ATOTAL
60 .I 'AAAFLAG D
61 ..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
62 ..Q:'SPDIEN
63 ..K DIE S DIE="^PS(52.7,",DA=SOLIEN,DR="9////"_SPDIEN D ^DIE K DIE
64 ..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
65 ...S ^PS(50.7,SPDIEN,2,AAACT,0)=SYNONYM,^PS(50.7,SPDIEN,2,"B",SYNONYM,AAACT)=""
66 ..I AAACT S ^PS(50.7,SPDIEN,2,0)="^50.72^"_AAACT_"^"_AAACT
67 ;FOR SYN, CHECK FOR NOT ALREADY EXISTING!!
68 ;
69XREF ; do next line to xref whole file after looping thru ^TMP to populate
70 ;******************DON'T EVEN DO THIS *******************
71 ;I $D(PSLOAD) S DIK="^PS(50.7," D IXALL^DIK K DIK
72 Q
73 ;
74DUPL ; see if there's already an orderable item with the same name and dosage form
75 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
76 Q
Note: See TracBrowser for help on using the repository browser.