source: FOIAVistA/tag/r/PHARMACY_DATA_MANAGEMENT-PSS/PSSDEE1.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1PSSDEE1 ;BIR/WRT-PDM match routine ;09/01/98
2 ;;1.0;PHARMACY DATA MANAGEMENT;**15,20,34,38,68,90**;9/30/97
3 ;
4 ;Reference to $$PSJDF^PSNAPIS(P1,P3) supported by DBIA #2531
5 ;
6DSPY S FLGMTH=0 I $D(^PSDRUG(DA,"ND")) I $P(^PSDRUG(DA,"ND"),"^",2)]"" W !!,?5,"points to ",$P(^("ND"),"^",2)," in the National Drug file.",! S NDE=^PSDRUG(DA,"ND"),PC1=$P(NDE,"^",1),PC3=$P(NDE,"^",3),FLGMTH=1 D GETDF
7 I $D(^PSDRUG(DA,2)),$P(^PSDRUG(DA,2),"^",1)]"" S PSSOITM=$P(^PSDRUG(DA,2),"^",1) I $D(^PS(50.7,PSSOITM,0)) S PTR=$P(^PS(50.7,PSSOITM,0),"^",2),OLDDF=$P(^PS(50.606,PTR,0),"^",1)
8 Q
9GETDF S DA=PC1,K=PC3,X=$$PSJDF^PSNAPIS(DA,K),OLDDF=$P(X,"^",2),DA=DISPDRG
10 Q
11MESSAGE ; REMATCH PROMPT
12 I $D(^PSDRUG(DA,"ND")) W:$P(^PSDRUG(DA,"ND"),"^",2)]"" !!,"This drug has already been matched and classified with the National Drug",!,"file." D PART2
13 I $D(^PSDRUG(DA,3)) W:$P(^PSDRUG(DA,3),"^",1)=1 !,"This drug has also been marked to transmit to CMOP.",!,"If you choose to rematch it, the drug will be marked NOT TO TRANSMIT to CMOP.",!
14 I $D(^PSDRUG(DA,"ND")) W:$P(^PSDRUG(DA,"ND"),"^",2)']"" !!,"This drug has been manually classed but not matched (merged with NDF)."
15 Q
16RSET S:$D(^PSDRUG(DA,"ND")) PSNID=$P(^PSDRUG(DA,"ND"),"^",10)
17 S PSNP=$G(^PSDRUG(DA,"I")) I PSNP,PSNP<DT W !,"This drug cannot be matched because it has an INACTIVE date.",! Q:$D(^PSDRUG(DA,"I"))
18 S DA=DISPDRG D:$D(^PSDRUG(DA,"ND")) SETNULL S:$D(^PSDRUG(DA,3)) $P(^PSDRUG(DA,3),"^",1)=0 K:$D(^PSDRUG("AQ",DA)) ^PSDRUG("AQ",DA) I $D(PSNID),PSNID]"" K ^PSDRUG("AQ1",PSNID,DA) K PSNID
19 D ^PSSREF Q
20SETNULL S ZXZX=$P(^PSDRUG(DA,"ND"),"^",2),$P(^PSDRUG(DA,"ND"),"^",1)="",$P(^PSDRUG(DA,"ND"),"^",2)="",$P(^PSDRUG(DA,"ND"),"^",3)="",$P(^PSDRUG(DA,"ND"),"^",4)="",$P(^PSDRUG(DA,"ND"),"^",5)="",$P(^PSDRUG(DA,"ND"),"^",10)="" D NULL1
21 Q
22NULL1 I ZXZX]"" S ZXZX=$E(ZXZX,1,30) I $D(^PSDRUG("VAPN",ZXZX,DA)) K ^PSDRUG("VAPN",ZXZX,DA) K ZXZX
23 Q
24PART2 W:$P(^PSDRUG(DA,"ND"),"^",2)]"" " In addition, if the dosage form changes as a result of rematching,",!,"you will have to match/rematch to Orderable Item."
25 Q
26ORDITM I FLGKY'=1 I $D(^PSDRUG(DISPDRG,2)) S APU=$P(^PSDRUG(DISPDRG,2),"^",3) I (APU["O")!(APU["I")!(APU["U")!(APU["X") D OICK
27 Q
28OICK I ^XMB("NETNAME")'["CMOP-",$D(^PS(59.7,1,80)),$P(^PS(59.7,1,80),"^",2)>1 D OIMESS S PSIEN=DISPDRG,PSNAME=$P(^PSDRUG(DISPDRG,0),"^",1),PSMASTER=1 D MAS^PSSPOIMN K PSIEN,PSNAME,PSMASTER
29 Q
30OIKILL I $D(FLGNDF),FLGNDF=1,$D(PSDRUG(DISPDRG,2)),$P(^PSDRUG(DISPDRG,2),"^",1)]"" D KMTCH
31 Q
32KMTCH S DIE="^PSDRUG(",DR="2.1///"_"@" D ^DIE D D CKIV
33 .;S PSSINSTX=$O(^PS(59.7,0)) I $P($G(^PS(59.7,+$G(PSSINSTX),80)),"^",3)<2 K PSSINSTX Q
34 .K PSSINSTX W !!,"Deleting Local Possible Dosages.." K ^PSDRUG(DISPDRG,"DOS2")
35 Q
36OIMESS W !!,"** You are NOW in the ORDERABLE ITEM matching for the dispense drug. **",!
37 Q
38CKIV K ^TMP($J,"SOL"),^TMP($J,"ADD") ;D SOLIO
39 ;D ADDIO
40 Q
41SOLIO I $D(^PS(52.7,"AC",DISPDRG)) F BBC=0:0 S BBC=$O(^PS(52.7,"AC",DISPDRG,BBC)) Q:'BBC S SOLITM=$P(^PS(52.7,BBC,0),"^",11) I SOLITM]"" I $D(^PS(52.7,"AOI",SOLITM,BBC)) D SOLIO1
42 Q
43SOLIO1 S IVDFPTR=$P(^PS(50.7,SOLITM,0),"^",2),IVDF=$P(^PS(50.606,IVDFPTR,0),"^",1),SOLNM=$P(^PS(52.7,BBC,0),"^",1) D CP
44 Q
45CP I IVDF'=NEWDF S ^TMP($J,"SOL",BBC)=SOLNM I $P(^PS(52.7,BBC,0),"^",11)]"" S DA=BBC,DIE="^PS(52.7,",DR="9///"_"@" D ^DIE
46 Q
47SOLMESS ;I FLG3=1,PSSANS'["I",$D(^TMP($J,"SOL")) W !,"You have SOLUTIONS that need to rematched to ORDERABLE ITEM." F NUM=0:0 S NUM=$O(^TMP($J,"SOL",NUM)) Q:'NUM S ENTRY=NUM D SOI^PSSVIDRG K ^TMP($J,"SOL",NUM)
48 Q
49ADDIO I $D(^PS(52.6,"AC",DISPDRG)) F BBC=0:0 S BBC=$O(^PS(52.6,"AC",DISPDRG,BBC)) Q:'BBC S ADDITM=$P(^PS(52.6,BBC,0),"^",11) I ADDITM]"",$D(^PS(52.6,"AOI",ADDITM,BBC)) D ADDIO1
50 Q
51ADDIO1 S IVDFPTR=$P(^PS(50.7,ADDITM,0),"^",2),IVDF=$P(^PS(50.606,IVDFPTR,0),"^",1),ADDNM=$P(^PS(52.6,BBC,0),"^",1) D CP1
52 Q
53CP1 I IVDF'=NEWDF S ^TMP($J,"ADD",BBC)=ADDNM I $P(^PS(52.6,BBC,0),"^",11)]"" S DA=BBC,DIE="^PS(52.6,",DR="15///"_"@" D ^DIE
54 Q
55ADDMESS ;I FLG3=1,PSSANS'["I",$D(^TMP($J,"ADD")) W !!,"You have ADDITIVES that need to rematched to ORDERABLE ITEM." F NUM=0:0 S NUM=$O(^TMP($J,"ADD",NUM)) Q:'NUM S ENTRY=NUM D ADDOI^PSSVIDRG K ^TMP($J,"ADD",NUM)
56 Q
57ADDMESS1 ;I FLG3=0,$D(^TMP($J,"ADD")) W !!,"The following ADDITIVES need to rematched to ORDERABLE ITEM, however you do",!,"not have the ""PSJI MGR"" IV key. These must be matched before they made be used.",! D MESSA
58 Q
59MESSA F NUM=0:0 S NUM=$O(^TMP($J,"ADD",NUM)) Q:'NUM W !?3,$P(^TMP($J,"ADD",NUM),"^")
60 Q
61SOLMESS1 ;I FLG3=0,$D(^TMP($J,"SOL")) W !!,"The following SOLUTIONS need to rematched to ORDERABLE ITEM, however you do",!,"not have the ""PSJI MGR"" IV key. These must be matched before they may be used.",! D MESSS
62 Q
63MESSS F NUM=0:0 S NUM=$O(^TMP($J,"SOL",NUM)) Q:'NUM W !?3,$P(^TMP($J,"SOL",NUM),"^")
64 Q
65ADDMESS2 ;I FLG3=1,PSSANS["I",$D(^TMP($J,"ADD")) W !!,"The following ADDITIVES need to rematched to ORDERABLE ITEM.",!,"These must be matched before they made be used.",! D MESSA
66 Q
67SOLMESS2 ;I FLG3=1,PSSANS["I",$D(^TMP($J,"SOL")) W !!,"The following SOLUTIONS need to rematched to ORDERABLE ITEM.",!,"These must be matched before they may be used.",! D MESSS
68 Q
Note: See TracBrowser for help on using the repository browser.